[COMMITTED 25/35] ada: Fix reason code for length check
From: Ronan Desplanques
This patch fixes the reason code used by Apply_Selected_Length_Checks,
which was wrong in some cases when the check could be determined to
always fail at compile time.
gcc/ada/
* checks.adb (Apply_Selected_Length_Checks): Fix reason code.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/checks.adb | 13 -
1 file changed, 8 insertions(+), 5 deletions(-)
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 4e3eb502706..6af392eeda8 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -322,7 +322,8 @@ package body Checks is
-- that the access value is non-null, since the checks do not
-- not apply to null access values.
- procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
+ procedure Install_Static_Check
+ (R_Cno : Node_Id; Loc : Source_Ptr; Reason : RT_Exception_Code);
-- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
-- Constraint_Error node.
@@ -3001,7 +3002,7 @@ package body Checks is
Insert_Action (Insert_Node, R_Cno);
else
-Install_Static_Check (R_Cno, Loc);
+Install_Static_Check (R_Cno, Loc, CE_Range_Check_Failed);
end if;
end loop;
end Apply_Range_Check;
@@ -3469,7 +3470,7 @@ package body Checks is
end if;
else
-Install_Static_Check (R_Cno, Loc);
+Install_Static_Check (R_Cno, Loc, CE_Length_Check_Failed);
end if;
end loop;
end Apply_Selected_Length_Checks;
@@ -8692,14 +8693,16 @@ package body Checks is
-- Install_Static_Check --
--
- procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
+ procedure Install_Static_Check
+ (R_Cno : Node_Id; Loc : Source_Ptr; Reason : RT_Exception_Code)
+ is
Stat : constant Boolean := Is_OK_Static_Expression (R_Cno);
Typ : constant Entity_Id := Etype (R_Cno);
begin
Rewrite (R_Cno,
Make_Raise_Constraint_Error (Loc,
- Reason => CE_Range_Check_Failed));
+ Reason => Reason));
Set_Analyzed (R_Cno);
Set_Etype (R_Cno, Typ);
Set_Raises_Constraint_Error (R_Cno);
--
2.43.2
[COMMITTED 11/35] ada: Follow up fixes for Put_Image/streaming regressions
From: Steve Baird A recent change to reduce duplication of compiler-generated Put_Image and streaming subprograms introduced some regressions. The fix for one of them was incomplete. gcc/ada/ * exp_attr.adb (Build_And_Insert_Type_Attr_Subp): Further tweaking of the point where a compiler-generated Put_Image or streaming subprogram is to be inserted in the tree. If one such subprogram calls another (as is often the case with, for example, Put_Image procedures for composite type and for a component type thereof), then we want to avoid use-before-definition problems that can result from inserting the caller ahead of the callee. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_attr.adb | 38 ++ 1 file changed, 38 insertions(+) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index e12e8b4a439..03bf4cf329c 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1954,6 +1954,44 @@ package body Exp_Attr is while Present (Ancestor) loop if Is_List_Member (Ancestor) then Insertion_Point := First (List_Containing (Ancestor)); + + -- A hazard to avoid here is use-before-definition + -- errors that can result when we have two of these + -- subprograms where one calls the other (e.g., given + -- Put_Image procedures for a composite type and + -- for a component type, the former will often call + -- the latter). At the time a subprogram is inserted, + -- we know that the one and only call to it is + -- somewhere in the subtree rooted at Ancestor. + -- So that placement constraint is easy to satisfy. + -- But if we construct another subprogram later and + -- if that second subprogram calls the first one, + -- then we need to be careful not to place the + -- second one ahead of the first one. That is the goal + -- of this loop. This may need to be revised if it turns + -- out that other stuff is being inserted on the list, + -- so that the loop terminates too early. + + -- On the other hand, it seems like inserting things + -- earlier offers more opportunities for sharing. + -- If Ancestor occurs in the statement list of a + -- subprogram body (ignore the HSS node for now), + -- then perhaps we should look for an insertion site + -- in the decl list of the subprogram body and only + -- look in the statement list if the decl list is empty. + -- Similarly if Ancestor occors in the private decls list + -- for a package spec that has a non-empty visible + -- decls list. No examples where this would result in more + -- sharing and less duplication have been observed, so this + -- is just speculation. + + while Insertion_Point /= Ancestor +and then Nkind (Insertion_Point) = N_Subprogram_Body +and then not Comes_From_Source (Insertion_Point) + loop + Next (Insertion_Point); + end loop; + pragma Assert (Present (Insertion_Point)); end if; Ancestor := Parent (Ancestor); -- 2.43.2
[COMMITTED 14/35] ada: Fix bogus error on function returning noncontrolling result in private part
From: Eric Botcazou
This occurs in the additional case of RM 3.9.3(10) in Ada 2012, that is to
say the access controlling result, because the implementation does not use
the same (correct) conditions as in the original case.
This factors out these conditions and uses them in both cases, as well as
adjusts the wording of the message in the first case.
gcc/ada/
* sem_ch6.adb (Check_Private_Overriding): Implement the second part
of RM 3.9.3(10) consistently in both cases.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch6.adb | 23 +--
1 file changed, 9 insertions(+), 14 deletions(-)
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index c0bfe873111..0a8030cb923 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -11555,35 +11555,30 @@ package body Sem_Ch6 is
Incomplete_Or_Partial_View (T);
begin
- if not Overrides_Visible_Function (Partial_View) then
+ if not Overrides_Visible_Function (Partial_View)
+ and then
+ Is_Tagged_Type
+ (if Present (Partial_View) then Partial_View else T)
+ then
-- Here, S is "function ... return T;" declared in
-- the private part, not overriding some visible
-- operation. That's illegal in the tagged case
-- (but not if the private type is untagged).
-if ((Present (Partial_View)
- and then Is_Tagged_Type (Partial_View))
- or else (No (Partial_View)
-and then Is_Tagged_Type (T)))
- and then T = Base_Type (Etype (S))
-then
+if T = Base_Type (Etype (S)) then
Error_Msg_N
- ("private function with tagged result must"
+ ("private function with controlling result must"
& " override visible-part function", S);
Error_Msg_N
("\move subprogram to the visible part"
& " (RM 3.9.3(10))", S);
-- Ada 2012 (AI05-0073): Extend this check to the case
--- of a function whose result subtype is defined by an
--- access_definition designating specific tagged type.
+-- of a function with access result type.
elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
- and then Is_Tagged_Type (Designated_Type (Etype (S)))
- and then
-not Is_Class_Wide_Type
- (Designated_Type (Etype (S)))
+ and then T = Base_Type (Designated_Type (Etype (S)))
and then Ada_Version >= Ada_2012
then
Error_Msg_N
--
2.43.2
[COMMITTED 16/35] ada: Fix latent alignment issue for dynamically-allocated controlled objects
From: Eric Botcazou Dynamically-allocated controlled objects are attached to a finalization collection by means of a hidden header placed right before the object, which means that the size effectively allocated must naturally account for the size of this header. But the allocation must also account for the alignment of this header in order to have it properly aligned. gcc/ada/ * libgnat/s-finpri.ads (Header_Alignment): New function. (Header_Size): Adjust description. (Master_Node): Put Finalize_Address as first component. (Collection_Node): Likewise. * libgnat/s-finpri.adb (Header_Alignment): New function. (Header_Size): Return the object size in storage units. * libgnat/s-stposu.ads (Adjust_Controlled_Dereference): Replace collection node with header in description. * libgnat/s-stposu.adb (Adjust_Controlled_Dereference): Likewise. (Allocate_Any_Controlled): Likewise. Pass the maximum of the specified alignment and that of the header to the allocator. (Deallocate_Any_Controlled): Likewise to the deallocator. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-finpri.adb | 11 +- gcc/ada/libgnat/s-finpri.ads | 21 +++ gcc/ada/libgnat/s-stposu.adb | 69 +--- gcc/ada/libgnat/s-stposu.ads | 2 +- 4 files changed, 66 insertions(+), 37 deletions(-) diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb index 09f2761a5b9..5bd8eeaea22 100644 --- a/gcc/ada/libgnat/s-finpri.adb +++ b/gcc/ada/libgnat/s-finpri.adb @@ -389,13 +389,22 @@ package body System.Finalization_Primitives is end if; end Finalize_Object; + -- + -- Header_Alignment -- + -- + + function Header_Alignment return System.Storage_Elements.Storage_Count is + begin + return Collection_Node'Alignment; + end Header_Alignment; + - -- Header_Size -- - function Header_Size return System.Storage_Elements.Storage_Count is begin - return Collection_Node'Size / Storage_Unit; + return Collection_Node'Object_Size / Storage_Unit; end Header_Size; diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads index 4ba13dadec0..468aa584958 100644 --- a/gcc/ada/libgnat/s-finpri.ads +++ b/gcc/ada/libgnat/s-finpri.ads @@ -168,8 +168,11 @@ package System.Finalization_Primitives with Preelaborate is -- Calls to the procedure with an object that has already been detached -- have no effects. + function Header_Alignment return System.Storage_Elements.Storage_Count; + -- Return the alignment of type Collection_Node as Storage_Count + function Header_Size return System.Storage_Elements.Storage_Count; - -- Return the size of type Collection_Node as Storage_Count + -- Return the object size of type Collection_Node as Storage_Count private @@ -182,11 +185,13 @@ private -- Finalization masters: - -- Master node type structure + -- Master node type structure. Finalize_Address comes first because it is + -- an access-to-subprogram and, therefore, might be twice as large and as + -- aligned as an access-to-object on some platforms. type Master_Node is record - Object_Address : System.Address := System.Null_Address; Finalize_Address : Finalize_Address_Ptr := null; + Object_Address : System.Address := System.Null_Address; Next : Master_Node_Ptr := null; end record; @@ -211,15 +216,17 @@ private -- Finalization collections: - -- Collection node type structure + -- Collection node type structure. Finalize_Address comes first because it + -- is an access-to-subprogram and, therefore, might be twice as large and + -- as aligned as an access-to-object on some platforms. type Collection_Node is record - Enclosing_Collection : Finalization_Collection_Ptr := null; - -- A pointer to the collection to which the node is attached - Finalize_Address : Finalize_Address_Ptr := null; -- A pointer to the Finalize_Address procedure of the object + Enclosing_Collection : Finalization_Collection_Ptr := null; + -- A pointer to the collection to which the node is attached + Prev : Collection_Node_Ptr := null; Next : Collection_Node_Ptr := null; -- Collection nodes are managed as a circular doubly-linked list diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb index 38dc69f976a..84535d2a506 100644 --- a/gcc/ada/libgnat/s-stposu.adb +++ b/gcc/ada/libgnat/s-stposu.adb @@ -56,12 +56,12 @@ package body System.Storage_Pools.Subpools is Header_And_Padding : constant Storage_Offset := Header_Size_With_Padding (Alignment); begin - -- Expose the collection node and its padding by shifting
[COMMITTED 21/35] ada: Fix detection of if_expressions that are known on entry
From: Piotr Trojanek Fix a small glitch in routine Is_Known_On_Entry, which returned False for all if_expressions, regardless whether their conditions or dependent expressions are known on entry. gcc/ada/ * sem_util.adb (Is_Known_On_Entry): Check whether condition and dependent expressions of an if_expression are known on entry. 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 68e131db606..766cabfc109 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -30784,9 +30784,7 @@ package body Sem_Util is return Is_Known_On_Entry (Expression (Expr)); when N_If_Expression => - if not All_Exps_Known_On_Entry (Expressions (Expr)) then - return False; - end if; + return All_Exps_Known_On_Entry (Expressions (Expr)); when N_Case_Expression => if not Is_Known_On_Entry (Expression (Expr)) then -- 2.43.2
[COMMITTED 07/35] ada: Remove Aspect_Specifications field from N_Procedure_Specification
From: Piotr Trojanek Sync Has_Aspect_Specifications_Flag with the actual flags in the AST. Code cleanup; behavior is unaffected. gcc/ada/ * gen_il-gen-gen_nodes.adb (N_Procedure_Specification): Remove Aspect_Specifications field. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gen_il-gen-gen_nodes.adb | 1 - 1 file changed, 1 deletion(-) diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index f3dc215673a..a7021dc49bb 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -736,7 +736,6 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Null_Present, Flag), Sy (Must_Override, Flag), Sy (Must_Not_Override, Flag), -Sy (Aspect_Specifications, List_Id, Default_No_List), Sm (Null_Statement, Node_Id))); Ab (N_Access_To_Subprogram_Definition, Node_Kind); -- 2.43.2
[COMMITTED 12/35] ada: Fix crash with -gnatdJ and -gnatw_q
From: Ronan Desplanques
This commit makes the emission of -gnatw_q warnings pass node information
so as to handle the enclosing subprogram display of -gnatdJ instead of
crashing.
gcc/ada/
* exp_ch4.adb (Expand_Composite_Equality): Call Error_Msg_N
instead of Error_Msg.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch4.adb | 8
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 762e75616a7..7a2003691ec 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -2340,12 +2340,12 @@ package body Exp_Ch4 is
pragma Assert
(Is_First_Subtype (Outer_Type)
or else Is_Generic_Actual_Type (Outer_Type));
- Error_Msg_Node_1 := Outer_Type;
Error_Msg_Node_2 := Comp_Type;
- Error_Msg
- ("?_q?""="" for type & uses predefined ""="" for }", Loc);
+ Error_Msg_N
+ ("?_q?""="" for type & uses predefined ""="" for }",
+ Outer_Type);
Error_Msg_Sloc := Sloc (Op);
- Error_Msg ("\?_q?""="" # is ignored here", Loc);
+ Error_Msg_N ("\?_q?""="" # is ignored here", Outer_Type);
end if;
end;
--
2.43.2
[COMMITTED 20/35] ada: Fix comments about Get_Ranged_Checks
From: Ronan Desplanques Checks.Get_Ranged_Checks was onced named Range_Check, and a few comments referred to it by that name before this commit. To avoid confusion with Types.Range_Check, this commits fixes those comments. gcc/ada/ * checks.ads: Fix comments. * checks.adb: Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/checks.adb | 4 ++-- gcc/ada/checks.ads | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index c81482a7b05..4e3eb502706 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -346,7 +346,7 @@ package body Checks is Warn_Node : Node_Id) return Check_Result; -- Like Apply_Selected_Length_Checks, except it doesn't modify -- anything, just returns a list of nodes as described in the spec of - -- this package for the Range_Check function. + -- this package for the Get_Range_Checks function. -- ??? In fact it does construct the test and insert it into the tree, -- and insert actions in various ways (calling Insert_Action directly -- in particular) so we do not call it in GNATprove mode, contrary to @@ -359,7 +359,7 @@ package body Checks is Warn_Node : Node_Id) return Check_Result; -- Like Apply_Range_Check, except it does not modify anything, just -- returns a list of nodes as described in the spec of this package - -- for the Range_Check function. + -- for the Get_Range_Checks function. -- -- Access_Checks_Suppressed -- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 36b5fa490fe..010627c3b03 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -980,7 +980,7 @@ package Checks is private type Check_Result is array (Positive range 1 .. 2) of Node_Id; - -- There are two cases for the result returned by Range_Check: + -- There are two cases for the result returned by Get_Range_Checks: -- --For the static case the result is one or two nodes that should cause --a Constraint_Error. Typically these will include Expr itself or the -- 2.43.2
[COMMITTED 23/35] ada: Improve recovery from illegal occurrence of 'Old in if_expression
From: Piotr Trojanek
Fix assertion failure in developer builds which happened when the THEN
expression contains an illegal occurrence of 'Old and the type of the
THEN expression is left as Any_Type, but there is no ELSE expression.
gcc/ada/
* sem_ch4.adb (Analyze_If_Expression): Add guard for
if_expression without an ELSE part.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch4.adb | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index b4414a3f7ff..03364dade9f 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2645,7 +2645,7 @@ package body Sem_Ch4 is
("\ELSE expression has}!", Else_Expr, Etype (Else_Expr));
end if;
- else
+ elsif Present (Else_Expr) then
if Is_Overloaded (Else_Expr) then
Error_Msg_N
("no interpretation compatible with type of THEN expression",
--
2.43.2
[COMMITTED 15/35] ada: Fix resolving tagged operations in array aggregates
From: Viljar Indus In the Two_Pass_Aggregate_Expansion we were removing all of the entity links in the Iterator_Specification to avoid reusing the same Iterator_Definition in both loops. However this approach was also breaking the links to calls with dot notation that had been transformed to the regular call notation. In order to circumvent this, explicitly create new identifier definitions when copying the Iterator_Specfications for both of the loops. gcc/ada/ * exp_aggr.adb (Two_Pass_Aggregate_Expansion): Explicitly create new Defining_Iterators for both of the loops. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 19 +-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index bdaca4aab58..f04dba719d9 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5714,6 +5714,7 @@ package body Exp_Aggr is Iter : Node_Id; New_Comp : Node_Id; One_Loop : Node_Id; + Iter_Id : Entity_Id; Size_Expr_Code : List_Id; Insertion_Code : List_Id := New_List; @@ -5730,6 +5731,7 @@ package body Exp_Aggr is while Present (Assoc) loop Iter := Iterator_Specification (Assoc); +Iter_Id := Defining_Identifier (Iter); Incr := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Size_Id, Loc), Expression => @@ -5737,10 +5739,16 @@ package body Exp_Aggr is Left_Opnd => New_Occurrence_Of (Size_Id, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1))); +-- Avoid using the same iterator definition in both loops by +-- creating a new iterator for each loop and mapping it over the +-- original iterator references. + One_Loop := Make_Implicit_Loop_Statement (N, Iteration_Scheme => Make_Iteration_Scheme (Loc, - Iterator_Specification => New_Copy_Tree (Iter)), + Iterator_Specification => + New_Copy_Tree (Iter, +Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id, Statements => New_List (Incr)); Append (One_Loop, Size_Expr_Code); @@ -5837,6 +5845,7 @@ package body Exp_Aggr is while Present (Assoc) loop Iter := Iterator_Specification (Assoc); +Iter_Id := Defining_Identifier (Iter); New_Comp := Make_Assignment_Statement (Loc, Name => Make_Indexed_Component (Loc, @@ -5869,10 +5878,16 @@ package body Exp_Aggr is Attribute_Name => Name_Last)), Then_Statements => New_List (Incr)); +-- Avoid using the same iterator definition in both loops by +-- creating a new iterator for each loop and mapping it over the +-- original iterator references. + One_Loop := Make_Implicit_Loop_Statement (N, Iteration_Scheme => Make_Iteration_Scheme (Loc, - Iterator_Specification => Copy_Separate_Tree (Iter)), + Iterator_Specification => + New_Copy_Tree (Iter, +Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id, Statements => New_List (New_Comp, Incr)); Append (One_Loop, Insertion_Code); -- 2.43.2
[COMMITTED 06/35] ada: Reuse existing expression when rewriting aspects to pragmas
From: Piotr Trojanek Code cleanup; semantics is unaffected. gcc/ada/ * sem_ch13.adb (Analyze_Aspect_Specification): Consistently reuse existing constant where possible. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch13.adb | 10 +- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ce9f15c1491..00392ae88eb 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1838,7 +1838,7 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Loc, Expression => Conv), Make_Pragma_Argument_Association (Loc, - Expression => New_Occurrence_Of (E, Loc; + Expression => Ent))); Decorate (Aspect, Aitem); Insert_Pragma (Aitem); @@ -3099,7 +3099,7 @@ package body Sem_Ch13 is Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, - Expression => New_Occurrence_Of (E, Loc)), + Expression => Ent), Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr))), Pragma_Name => Name_Linker_Section); @@ -3120,7 +3120,7 @@ package body Sem_Ch13 is Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, - Expression => New_Occurrence_Of (E, Loc)), + Expression => Ent), Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr))), Pragma_Name => Name_Implemented); @@ -3439,7 +3439,7 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr)), Make_Pragma_Argument_Association (Sloc (Expr), - Expression => New_Occurrence_Of (E, Loc))), + Expression => Ent)), Pragma_Name => Nam); Delay_Required := False; @@ -3452,7 +3452,7 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr)), Make_Pragma_Argument_Association (Loc, - Expression => New_Occurrence_Of (E, Loc))), + Expression => Ent)), Pragma_Name => Name_Warnings); Decorate (Aspect, Aitem); -- 2.43.2
[COMMITTED 09/35] ada: Formal_Derived_Type'Size is not static
From: Steve Baird In deciding whether a Size attribute reference is static, the compiler could get confused about whether an implicitly-declared subtype of a generic formal type is itself a generic formal type, possibly resulting in an assertion failure and then a bugbox. gcc/ada/ * sem_attr.adb (Eval_Attribute): Expand existing checks for generic formal types for which Is_Generic_Type returns False. In that case, mark the attribute reference as nonstatic. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_attr.adb | 10 ++ 1 file changed, 10 insertions(+) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 65442d45a85..2fa7d7d25d2 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -8685,10 +8685,20 @@ package body Sem_Attr is -- If the root type or base type is generic, then we cannot fold. This -- test is needed because subtypes of generic types are not always -- marked as being generic themselves (which seems odd???) + -- + -- Should this situation be addressed instead by either + -- a) setting Is_Generic_Type in more cases + -- or b) replacing preceding calls to Is_Generic_Type with calls to + --Sem_Util.Some_New_Function + -- so that we wouldn't have to deal with these cases here ??? if Is_Generic_Type (P_Root_Type) or else Is_Generic_Type (P_Base_Type) +or else (Present (Associated_Node_For_Itype (P_Base_Type)) + and then Is_Generic_Type (Defining_Identifier + (Associated_Node_For_Itype (P_Base_Type then + Set_Is_Static_Expression (N, False); return; end if; -- 2.43.2
[COMMITTED 13/35] ada: Fix casing of CUDA in error messages
From: Piotr Trojanek
Error messages now capitalize CUDA.
gcc/ada/
* erroutc.adb (Set_Msg_Insertion_Reserved_Word): Fix casing for
CUDA appearing in error message strings.
(Set_Msg_Str): Likewise for CUDA being a part of a Name_Id.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/erroutc.adb | 13 -
1 file changed, 12 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index be200e0016e..cef04d5daf2 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -1475,12 +1475,17 @@ package body Erroutc is
if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
Set_Msg_Name_Buffer;
+ -- We make a similar exception for CUDA
+
+ elsif Name_Len = 4 and then Name_Buffer (1 .. 4) = "CUDA" then
+ Set_Msg_Name_Buffer;
+
-- We make a similar exception for SPARK
elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
Set_Msg_Name_Buffer;
- -- Neither RM nor SPARK: case appropriately and add surrounding quotes
+ -- Otherwise, case appropriately and add surrounding quotes
else
Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
@@ -1608,6 +1613,12 @@ package body Erroutc is
elsif Text = "Cpp_Vtable" then
Set_Msg_Str ("CPP_Vtable");
+ elsif Text = "Cuda_Device" then
+ Set_Msg_Str ("CUDA_Device");
+
+ elsif Text = "Cuda_Global" then
+ Set_Msg_Str ("CUDA_Global");
+
elsif Text = "Persistent_Bss" then
Set_Msg_Str ("Persistent_BSS");
--
2.43.2
[COMMITTED 17/35] ada: Fix typo in CUDA error message
From: Piotr Trojanek
Fix typo in error message; semantics is unaffected.
gcc/ada/
* gnat_cuda.adb (Remove_CUDA_Device_Entities): Fix typo.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gnat_cuda.adb | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb
index 92576a4b397..b531c15d380 100644
--- a/gcc/ada/gnat_cuda.adb
+++ b/gcc/ada/gnat_cuda.adb
@@ -270,7 +270,7 @@ package body GNAT_CUDA is
and then Present (Corresponding_Stub (Parent (Bod)))
then
Error_Msg_N
-("CUDA_Device not suported on separate subprograms",
+("CUDA_Device not supported on separate subprograms",
Corresponding_Stub (Parent (Bod)));
else
Remove (Bod);
--
2.43.2
[COMMITTED 10/35] ada: Implement per-finalization-collection spinlocks
From: Eric Botcazou This changes the implementation of finalization collections from using the global task lock to using per-collection spinlocks. Spinlocks are a good fit in this context because they are very cheap and therefore can be taken with a fine granularity only around the portions of code implementing the shuffling of pointers required by attachment and detachment actions. gcc/ada/ * libgnat/s-finpri.ads (Lock_Type): New modular type. (Collection_Node): Add Enclosing_Collection component. (Finalization_Collection): Add Lock component. * libgnat/s-finpri.adb: Add clauses for System.Atomic_Primitives. (Attach_Object_To_Collection): Lock and unlock the collection. Save a pointer to the enclosing collection in the node. (Detach_Object_From_Collection): Lock and unlock the collection. (Finalize): Likewise. (Initialize): Initialize the lock. (Lock_Collection): New procedure. (Unlock_Collection): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-finpri.adb | 79 +--- gcc/ada/libgnat/s-finpri.ads | 12 +- 2 files changed, 75 insertions(+), 16 deletions(-) diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb index 8026b3fb284..09f2761a5b9 100644 --- a/gcc/ada/libgnat/s-finpri.adb +++ b/gcc/ada/libgnat/s-finpri.adb @@ -32,7 +32,8 @@ with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; -with System.Soft_Links; use System.Soft_Links; +with System.Atomic_Primitives; use System.Atomic_Primitives; +with System.Soft_Links;use System.Soft_Links; package body System.Finalization_Primitives is @@ -42,7 +43,21 @@ package body System.Finalization_Primitives is new Ada.Unchecked_Conversion (Address, Collection_Node_Ptr); procedure Detach_Node_From_Collection (Node : not null Collection_Node_Ptr); - -- Removes a collection node from its associated finalization collection + -- Remove a collection node from its associated finalization collection. + -- Calls to the procedure with a Node that has already been detached have + -- no effects. + + procedure Lock_Collection (Collection : in out Finalization_Collection); + -- Lock the finalization collection. Upon return, the caller owns the lock + -- to the collection and no other call with the same actual parameter will + -- return until a corresponding call to Unlock_Collection has been made by + -- the caller. This means that it is not possible to call Lock_Collection + -- more than once on a collection without a call to Unlock_Collection in + -- between. + + procedure Unlock_Collection (Collection : in out Finalization_Collection); + -- Unlock the finalization collection, i.e. relinquish ownership of the + -- lock to the collection. --- -- Add_Offset_To_Address -- @@ -69,7 +84,7 @@ package body System.Finalization_Primitives is To_Collection_Node_Ptr (Object_Address - Header_Size); begin - Lock_Task.all; + Lock_Collection (Collection); -- Do not allow the attachment of controlled objects while the -- associated collection is being finalized. @@ -89,22 +104,23 @@ package body System.Finalization_Primitives is pragma Assert (Finalize_Address /= null, "primitive Finalize_Address not available"); - Node.Finalize_Address := Finalize_Address; - Node.Prev := Collection.Head'Unchecked_Access; - Node.Next := Collection.Head.Next; + Node.Enclosing_Collection := Collection'Unrestricted_Access; + Node.Finalize_Address := Finalize_Address; + Node.Prev := Collection.Head'Unchecked_Access; + Node.Next := Collection.Head.Next; Collection.Head.Next.Prev := Node; Collection.Head.Next := Node; - Unlock_Task.all; + Unlock_Collection (Collection); exception when others => - -- Unlock the task in case the attachment failed and reraise the - -- exception. + -- Unlock the collection in case the attachment failed and reraise + -- the exception. - Unlock_Task.all; + Unlock_Collection (Collection); raise; end Attach_Object_To_Collection; @@ -180,11 +196,11 @@ package body System.Finalization_Primitives is To_Collection_Node_Ptr (Object_Address - Header_Size); begin - Lock_Task.all; + Lock_Collection (Node.Enclosing_Collection.all); Detach_Node_From_Collection (Node); - Unlock_Task.all; + Unlock_Collection (Node.Enclosing_Collection.all); end Detach_Object_From_Collection; -- @@ -213,14 +229,14 @@ package body System.Finalization_Primitives is end Is_Empty_List; begin - Lock_Task.all; + Lock_Collection (Collection);
[COMMITTED 03/35] ada: Fix ordering of code for pragma Preelaborable_Initialization
From: Piotr Trojanek
Code cleanup.
gcc/ada/
* sem_prag.adb (Analyze_Pragma): Move case alternative to match
to alphabetic order.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_prag.adb | 160 +--
1 file changed, 80 insertions(+), 80 deletions(-)
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 105cc73eba3..2fc46ab0cd2 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -21889,86 +21889,6 @@ package body Sem_Prag is
Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
end if;
- --
- -- Preelaborable_Initialization --
- --
-
- -- pragma Preelaborable_Initialization (DIRECT_NAME);
-
- when Pragma_Preelaborable_Initialization => Preelab_Init : declare
-Ent : Entity_Id;
-
- begin
-Ada_2005_Pragma;
-Check_Arg_Count (1);
-Check_No_Identifiers;
-Check_Arg_Is_Identifier (Arg1);
-Check_Arg_Is_Local_Name (Arg1);
-Check_First_Subtype (Arg1);
-Ent := Entity (Get_Pragma_Arg (Arg1));
-
--- A pragma that applies to a Ghost entity becomes Ghost for the
--- purposes of legality checks and removal of ignored Ghost code.
-
-Mark_Ghost_Pragma (N, Ent);
-
--- The pragma may come from an aspect on a private declaration,
--- even if the freeze point at which this is analyzed in the
--- private part after the full view.
-
-if Has_Private_Declaration (Ent)
- and then From_Aspect_Specification (N)
-then
- null;
-
--- Check appropriate type argument
-
-elsif Is_Private_Type (Ent)
- or else Is_Protected_Type (Ent)
- or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
-
- -- AI05-0028: The pragma applies to all composite types. Note
- -- that we apply this binding interpretation to earlier versions
- -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
- -- choice since there are other compilers that do the same.
-
- or else Is_Composite_Type (Ent)
-then
- null;
-
-else
- Error_Pragma_Arg
- ("pragma % can only be applied to private, formal derived, "
- & "protected, or composite type", Arg1);
-end if;
-
--- Give an error if the pragma is applied to a protected type that
--- does not qualify (due to having entries, or due to components
--- that do not qualify).
-
-if Is_Protected_Type (Ent)
- and then not Has_Preelaborable_Initialization (Ent)
-then
- Error_Msg_N
- ("protected type & does not have preelaborable "
- & "initialization", Ent);
-
--- Otherwise mark the type as definitely having preelaborable
--- initialization.
-
-else
- Set_Known_To_Have_Preelab_Init (Ent);
-end if;
-
-if Has_Pragma_Preelab_Init (Ent)
- and then Warn_On_Redundant_Constructs
-then
- Error_Pragma ("?r?duplicate pragma%!");
-else
- Set_Has_Pragma_Preelab_Init (Ent);
-end if;
- end Preelab_Init;
-
-- Persistent_BSS --
@@ -22057,6 +21977,86 @@ package body Sem_Prag is
end if;
end Persistent_BSS;
+ --
+ -- Preelaborable_Initialization --
+ --
+
+ -- pragma Preelaborable_Initialization (DIRECT_NAME);
+
+ when Pragma_Preelaborable_Initialization => Preelab_Init : declare
+Ent : Entity_Id;
+
+ begin
+Ada_2005_Pragma;
+Check_Arg_Count (1);
+Check_No_Identifiers;
+Check_Arg_Is_Identifier (Arg1);
+Check_Arg_Is_Local_Name (Arg1);
+Check_First_Subtype (Arg1);
+Ent := Entity (Get_Pragma_Arg (Arg1));
+
+-- A pragma that applies to a Ghost entity becomes Ghost for the
+-- purposes of legality checks and removal of ignored Ghost code.
+
+Mark_Ghost_Pragma (N, Ent);
+
+-- The pragma may come from an aspect on a private declaration,
+-- even if the freeze point at which this is analyzed in the
+-- private part after the full view.
+
+if Has_Private_Declaration (Ent)
+ and then From_Aspect_Specification (N)
+then
+ null;
+
+-- Check appropriate type argument
[COMMITTED 08/35] ada: Fix bug in maintaining dimension info
From: Steve Baird Copying a node does not automatically propagate its associated dimension information (if any). This must be done explicitly. gcc/ada/ * sem_util.adb (Copy_Node_With_Replacement): Add call to Copy_Dimensions so that any dimension information associated with the copied node is also associated with the resulting copy. 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 1785931530f..68e131db606 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -53,6 +53,7 @@ with Sem_Cat;use Sem_Cat; with Sem_Ch6;use Sem_Ch6; with Sem_Ch8;use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; +with Sem_Dim;use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; @@ -23447,6 +23448,8 @@ package body Sem_Util is Set_Chars (Result, Chars (Entity (Result))); end if; end if; + +Copy_Dimensions (From => N, To => Result); end if; return Result; -- 2.43.2
[COMMITTED 04/35] ada: Fix alphabetic ordering of aspect identifiers
From: Piotr Trojanek Code cleanup. gcc/ada/ * aspects.ads (Aspect_Id): Fix ordering. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/aspects.ads | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index eb5ab1a85dd..ce393d4f602 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -198,9 +198,9 @@ package Aspects is Aspect_Favor_Top_Level, -- GNAT Aspect_Full_Access_Only, Aspect_Ghost, -- GNAT + Aspect_Import, Aspect_Independent, Aspect_Independent_Components, - Aspect_Import, Aspect_Inline, Aspect_Inline_Always, -- GNAT Aspect_Interrupt_Handler, @@ -971,6 +971,7 @@ package Aspects is Aspect_Shared_Passive => Always_Delay, Aspect_Simple_Storage_Pool => Always_Delay, Aspect_Simple_Storage_Pool_Type => Always_Delay, + Aspect_Stable_Properties=> Always_Delay, Aspect_Static_Predicate => Always_Delay, Aspect_Storage_Model_Type => Always_Delay, Aspect_Storage_Pool => Always_Delay, @@ -1032,7 +1033,6 @@ package Aspects is Aspect_Relaxed_Initialization => Never_Delay, Aspect_Side_Effects => Never_Delay, Aspect_SPARK_Mode => Never_Delay, - Aspect_Stable_Properties=> Always_Delay, Aspect_Static => Never_Delay, Aspect_Subprogram_Variant => Never_Delay, Aspect_Synchronization => Never_Delay, -- 2.43.2
[COMMITTED 05/35] ada: Cleanup reporting locations for Ada 2022 and GNAT extension aspects
From: Piotr Trojanek
Code cleanup; semantics is unaffected.
gcc/ada/
* sem_ch13.adb (Analyze_Aspect_Specification): Consistently
reuse existing constant where possible.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch13.adb | 10 +-
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 8bc8e84ceb4..ce9f15c1491 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -2417,7 +2417,7 @@ package body Sem_Ch13 is
begin
if Ada_Version < Ada_2022 then
- Error_Msg_Ada_2022_Feature ("aspect %", Sloc (Aspect));
+ Error_Msg_Ada_2022_Feature ("aspect %", Loc);
return;
end if;
@@ -2442,7 +2442,7 @@ package body Sem_Ch13 is
elsif Is_Imported_Intrinsic then
Error_Msg_GNAT_Extension
- ("aspect % on intrinsic function", Sloc (Aspect),
+ ("aspect % on intrinsic function", Loc,
Is_Core_Extension => True);
else
@@ -4133,7 +4133,7 @@ package body Sem_Ch13 is
when Aspect_Designated_Storage_Model =>
if not All_Extensions_Allowed then
- Error_Msg_GNAT_Extension ("aspect %", Sloc (Aspect));
+ Error_Msg_GNAT_Extension ("aspect %", Loc);
elsif not Is_Type (E)
or else Ekind (E) /= E_Access_Type
@@ -4148,7 +4148,7 @@ package body Sem_Ch13 is
when Aspect_Storage_Model_Type =>
if not All_Extensions_Allowed then
- Error_Msg_GNAT_Extension ("aspect %", Sloc (Aspect));
+ Error_Msg_GNAT_Extension ("aspect %", Loc);
elsif not Is_Type (E)
or else not Is_Immutably_Limited_Type (E)
@@ -4479,7 +4479,7 @@ package body Sem_Ch13 is
-- Ada 2022 (AI12-0363): Full_Access_Only
elsif A_Id = Aspect_Full_Access_Only then
- Error_Msg_Ada_2022_Feature ("aspect %", Sloc (Aspect));
+ Error_Msg_Ada_2022_Feature ("aspect %", Loc);
-- Ada 2022 (AI12-0075): static expression functions
--
2.43.2
[COMMITTED 01/35] ada: Fix docs and comments about pragmas for Boolean-valued aspects
From: Piotr Trojanek Fix various inconsistencies in documentation and comments of Boolean-valued aspects. gcc/ada/ * doc/gnat_rm/implementation_defined_pragmas.rst: Fix documentation. * sem_prag.adb: Fix comments. * gnat_rm.texi: Regenerate. Tested on x86_64-pc-linux-gnu, committed on master. --- .../implementation_defined_pragmas.rst| 57 +++ gcc/ada/gnat_rm.texi | 57 +++ gcc/ada/sem_prag.adb | 48 3 files changed, 89 insertions(+), 73 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 3426c34ebe8..7f221e32344 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -341,7 +341,7 @@ Syntax: pragma Always_Terminates [ (boolean_EXPRESSION) ]; For the semantics of this pragma, see the entry for aspect ``Always_Terminates`` -in the SPARK 2014 Reference Manual, section 7.1.2. +in the SPARK 2014 Reference Manual, section 6.1.10. .. _Pragma-Annotate: @@ -2381,7 +2381,7 @@ Syntax: .. code-block:: ada - pragma Favor_Top_Level (type_NAME); + pragma Favor_Top_Level (type_LOCAL_NAME); The argument of pragma ``Favor_Top_Level`` must be a named access-to-subprogram @@ -2838,7 +2838,7 @@ Syntax: .. code-block:: ada - pragma Independent (Local_NAME); + pragma Independent (component_LOCAL_NAME); This pragma is standard in Ada 2012 mode (which also provides an aspect @@ -3537,6 +3537,11 @@ Pragma Lock_Free Syntax: + +.. code-block:: ada + + pragma Lock_Free [ (static_boolean_EXPRESSION) ]; + This pragma may be specified for protected types or objects. It specifies that the implementation of protected operations must be implemented without locks. Compilation fails if the compiler cannot generate lock-free code for the @@ -3850,7 +3855,7 @@ same name) that establishes the restriction ``No_Elaboration_Code`` for the current unit and any extended main source units (body and subunits). It also has the effect of enforcing a transitive application of this aspect, so that if any unit is implicitly or explicitly with'ed by the -current unit, it must also have the No_Elaboration_Code_All aspect set. +current unit, it must also have the `No_Elaboration_Code_All` aspect set. It may be applied to package or subprogram specs or their generic versions. Pragma No_Heap_Finalization @@ -4508,7 +4513,7 @@ Syntax: :: - pragma Persistent_BSS [(LOCAL_NAME)] + pragma Persistent_BSS [(object_LOCAL_NAME)] This pragma allows selected objects to be placed in the ``.persistent_bss`` @@ -6500,12 +6505,12 @@ Syntax: :: - pragma Suppress_Initialization ([Entity =>] variable_or_subtype_Name); + pragma Suppress_Initialization ([Entity =>] variable_or_subtype_LOCAL_NAME); -Here variable_or_subtype_Name is the name introduced by a type declaration -or subtype declaration or the name of a variable introduced by an -object declaration. +Here variable_or_subtype_LOCAL_NAME is the name introduced by a type +declaration or subtype declaration or the name of a variable introduced by +an object declaration. In the case of a type or subtype this pragma suppresses any implicit or explicit initialization @@ -6889,22 +6894,24 @@ Syntax: This configuration pragma defines a new aspect, making it available for -subsequent use in a User_Aspect aspect specification. The first -identifier is the name of the new aspect. Any subsequent arguments -specify the names of other aspects. A subsequent name for which no parenthesized -arguments are given shall denote either a Boolean-valued -non-representation aspect or an aspect that has been defined by another -User_Aspect_Definition pragma. A name for which one or more arguments are -given shall be either Annotate or Local_Restrictions (and the arguments shall -be appropriate for the named aspect). This pragma, together with the -User_Aspect aspect, provides a mechanism for -avoiding textual duplication if some set of aspect specifications is needed -in multiple places. This is somewhat analogous to how profiles allow avoiding -duplication of Restrictions pragmas. The visibility rules for an aspect -defined by a User_Aspect_Definition pragma are the same as for a check name -introduced by a Check_Name pragma. If multiple -definitions are visible for some aspect at some point, then the -definitions must agree. A predefined aspect cannot be redefined. +subsequent use in a `User_Aspect` aspect specification. The first identifier +is the name of the new aspect. Any subsequent arguments specify the names +of other aspects. A subsequent name for which no parenthesized arguments +are given shall denote either a Boolean-valued non-representation aspect +or an aspect that has been defined by another `User_Aspect_Definition` +pra
[COMMITTED 02/35] ada: Fix casing in error messages
From: Piotr Trojanek
Error messages should not start with a capital letter.
gcc/ada/
* gnat_cuda.adb (Remove_CUDA_Device_Entities): Fix casing
(this primarily fixes a style, because the capitalization will
not be preserved by the error-reporting machinery anyway).
* sem_ch13.adb (Analyze_User_Aspect_Aspect_Specification): Fix
casing in error message.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gnat_cuda.adb | 2 +-
gcc/ada/sem_ch13.adb | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb
index af47b728790..92576a4b397 100644
--- a/gcc/ada/gnat_cuda.adb
+++ b/gcc/ada/gnat_cuda.adb
@@ -270,7 +270,7 @@ package body GNAT_CUDA is
and then Present (Corresponding_Stub (Parent (Bod)))
then
Error_Msg_N
-("Cuda_Device not suported on separate subprograms",
+("CUDA_Device not suported on separate subprograms",
Corresponding_Stub (Parent (Bod)));
else
Remove (Bod);
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index eee2aa09cd5..8bc8e84ceb4 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -8754,7 +8754,7 @@ package body Sem_Ch13 is
Arg : Node_Id;
begin
if No (UAD_Pragma) then
-Error_Msg_N ("No definition for user-defined aspect", Id);
+Error_Msg_N ("no definition for user-defined aspect", Id);
return;
end if;
--
2.43.2
[COMMITTED] ada: Fix classification of SPARK Boolean aspects
From: Piotr Trojanek The implementation of User_Aspect_Definition uses subtype Boolean_Aspects to decide which existing aspects can be used to define old aspects. This subtype didn't include many of the SPARK aspects, notably the Always_Terminates. gcc/ada/ * aspects.ads (Aspect_Id, Boolean_Aspect): Change categorization of Boolean-valued SPARK aspects. * sem_ch13.adb (Analyze_Aspect_Specification): Adapt CASE statements to new classification of Boolean-valued SPARK aspects. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/aspects.ads | 39 - gcc/ada/sem_ch13.adb | 203 ++- 2 files changed, 41 insertions(+), 201 deletions(-) diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index a348b322d29..eb5ab1a85dd 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -72,14 +72,10 @@ package Aspects is Aspect_Address, Aspect_Aggregate, Aspect_Alignment, - Aspect_Always_Terminates, -- GNAT Aspect_Annotate, -- GNAT - Aspect_Async_Readers, -- GNAT - Aspect_Async_Writers, -- GNAT Aspect_Attach_Handler, Aspect_Bit_Order, Aspect_Component_Size, - Aspect_Constant_After_Elaboration,-- GNAT Aspect_Constant_Indexing, Aspect_Contract_Cases,-- GNAT Aspect_Convention, @@ -95,13 +91,9 @@ package Aspects is Aspect_Dimension_System, -- GNAT Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate, - Aspect_Effective_Reads, -- GNAT - Aspect_Effective_Writes, -- GNAT Aspect_Exceptional_Cases, -- GNAT - Aspect_Extensions_Visible,-- GNAT Aspect_External_Name, Aspect_External_Tag, - Aspect_Ghost, -- GNAT Aspect_Ghost_Predicate, -- GNAT Aspect_Global,-- GNAT Aspect_GNAT_Annotate, -- GNAT @@ -121,7 +113,6 @@ package Aspects is Aspect_Max_Entry_Queue_Depth, -- GNAT Aspect_Max_Entry_Queue_Length, Aspect_Max_Queue_Length, -- GNAT - Aspect_No_Caching,-- GNAT Aspect_No_Controlled_Parts, Aspect_No_Task_Parts, -- GNAT Aspect_Object_Size, -- GNAT @@ -146,7 +137,6 @@ package Aspects is Aspect_Relaxed_Initialization,-- GNAT Aspect_Scalar_Storage_Order, -- GNAT Aspect_Secondary_Stack_Size, -- GNAT - Aspect_Side_Effects, -- GNAT Aspect_Simple_Storage_Pool, -- GNAT Aspect_Size, Aspect_Small, @@ -168,7 +158,6 @@ package Aspects is Aspect_User_Aspect, -- GNAT Aspect_Value_Size,-- GNAT Aspect_Variable_Indexing, - Aspect_Volatile_Function, -- GNAT Aspect_Warnings, -- GNAT Aspect_Write, @@ -190,17 +179,25 @@ package Aspects is -- the aspect value is inherited from the parent, in which case, we do -- not allow False if we inherit a True value from the parent. + Aspect_Always_Terminates, -- GNAT Aspect_Asynchronous, + Aspect_Async_Readers, -- GNAT + Aspect_Async_Writers, -- GNAT Aspect_Atomic, Aspect_Atomic_Components, + Aspect_Constant_After_Elaboration,-- GNAT Aspect_Disable_Controlled,-- GNAT Aspect_Discard_Names, Aspect_CUDA_Device, -- GNAT Aspect_CUDA_Global, -- GNAT + Aspect_Effective_Reads, -- GNAT + Aspect_Effective_Writes, -- GNAT Aspect_Exclusive_Functions, Aspect_Export, + Aspect_Extensions_Visible,-- GNAT Aspect_Favor_Top_Level, -- GNAT Aspect_Full_Access_Only, + Aspect_Ghost, -- GNAT Aspect_Independent, Aspect_Independent_Components, Aspect_Import, @@ -208,6 +205,7 @@ package Aspects is Aspect_Inline_Always, -- GNAT Aspect_Interrupt_Handler, Aspect_Lock_Free, -- GNAT + Aspect_No_Caching,-- GNAT Aspect_No_Inline, -- GNAT Aspect_No_Return, Aspect_No_Tagged_Streams, -- GNAT @@ -217,6 +215,7 @@ package Aspects is Aspect_Pure_Function, -- GNAT Aspect_Remote_Access_Type,-- GNAT Aspect_Shared,-- GNAT (equivalent to Atomic) + Aspect_Side_Effects, -- GNAT Aspect_Simple_Storage_Pool_Type, -- GNAT Aspect_Static, Aspect_Suppress_Debug_Info,
[COMMITTED] ada: Document more details of the implementation of finalization chains
From: Eric Botcazou gcc/ada/ * exp_ch7.adb (Finalization Management): Add a short description of the implementation of finalization chains. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch7.adb | 29 + 1 file changed, 29 insertions(+) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index e978a778f1e..25a7c0b2b46 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -100,6 +100,35 @@ package body Exp_Ch7 is -- have to be detached from the finalization chain, in case (2) they must -- not and in case (1) this is optional as we are exiting the scope anyway. + -- There are two kinds of finalization chain to which objects are attached, + -- depending on the way they are created. For objects (statically) declared + -- in a scope, the finalization chain is that of the master of the scope, + -- which is embodied in a Finalization_Master object. As per RM 7.6.1(11/3) + -- the finalization of the master (on scope exit) performs the finalization + -- of objects attached to its chain in the reverse order of their creation. + + -- For dynamically allocated objects, the finalization chain is that of the + -- finalization collection of the access type through which the objects are + -- allocated, which is embodied in a Finalization_Collection object. As per + -- RM 7.6.1(11.1/3), the finalization of the collection performs the + -- finalization of objects attached to its chain in an arbitrary order. + + -- A Finalization_Collection object is implemented as a controlled object + -- and its finalization is therefore driven by the finalization master of + -- the scope where it is declared. As per RM 7.6.1(11.2/3), for a named + -- access type, the Finalization_Collection object is declared in the list + -- of actions of its freeze node. + + -- ??? For an anonymous access type, the implementation deviates from the + -- RM 7.6.1 clause as follows: all the anonymous access types with the same + -- designated type that are (implicitly) declared in a library unit share a + -- single Finalization_Collection object declared in the outermost scope of + -- the library unit, except if the designated type is declared in a dynamic + -- scope nested in the unit; in this case no Finalization_Collection object + -- is created. As a result, in the first case, objects allocated through + -- the anonymous access types are finalized when the library unit goes out + -- of scope, while in the second case, they are not finalized at all. + -- Here is a simple example of the expansion of a controlled block: --declare -- 2.43.2
[COMMITTED] ada: Follow up fixes for Put_Image/streaming regressions
From: Steve Baird A recent change to reduce duplication of compiler-generated Put_Image and streaming subprograms introduced two regressions. One is yet another of the many cases where generating these routines "on demand" (as opposed at the point of the associated type declaration) requires loosening the compiler's enforcement of privacy. The other is a use-before-definition issue that occurs because the declaration of a Put_Image procedure is not hoisted far enough. gcc/ada/ * exp_attr.adb (Build_And_Insert_Type_Attr_Subp): If a subprogram associated with a (library-level) type declared in another unit is to be inserted somewhere in a list, then insert it at the head of the list. * sem_ch5.adb (Analyze_Assignment): Normally a limited-type assignment is illegal. Relax this rule if Comes_From_Source is False and the type is not immutably limited. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_attr.adb | 3 ++- gcc/ada/sem_ch5.adb | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 6dba600620e..e12e8b4a439 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1953,7 +1953,8 @@ package body Exp_Attr is while Present (Ancestor) loop if Is_List_Member (Ancestor) then - Insertion_Point := Ancestor; + Insertion_Point := First (List_Containing (Ancestor)); + pragma Assert (Present (Insertion_Point)); end if; Ancestor := Parent (Ancestor); end loop; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 65370ebfe7e..1e09e57919e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -597,10 +597,13 @@ package body Sem_Ch5 is -- Error of assigning to limited type. We do however allow this in -- certain cases where the front end generates the assignments. + -- Comes_From_Source test is needed to allow compiler-generated + -- streaming/put_image subprograms, which may ignore privacy. elsif Is_Limited_Type (T1) and then not Assignment_OK (Lhs) and then not Assignment_OK (Original_Node (Lhs)) +and then (Comes_From_Source (N) or Is_Immutably_Limited_Type (T1)) then -- CPP constructors can only be called in declarations -- 2.43.2
[COMMITTED] ada: Fix crash with -gnatdJ and -gnatw.w
From: Ronan Desplanques
This patch fixes a crash when -gnatdJ is enabled and a warning
must be emitted about an ineffective pragma Warnings clause.
Some modifications are made to the specific warnings machinery so
that warnings carry the ID of the pragma node they're about, so the
-gnatdJ mechanism can find an appropriate enclosing subprogram.
gcc/ada/
* sem_prag.adb (Analyze_Pragma): Adapt call to new signature.
* erroutc.ads (Set_Specific_Warning_Off): change signature
and update documentation.
(Validate_Specific_Warnings): Move ...
* errout.adb: ... here and change signature. Also move body
of Validate_Specific_Warnings from erroutc.adb.
(Finalize): Adapt call.
* errout.ads (Set_Specific_Warning_Off): Adapt signature of
renaming.
* erroutc.adb (Set_Specific_Warning_Off): Adapt signature and
body.
(Validate_Specific_Warnings): Move to the body of Errout.
(Warning_Specifically_Suppressed): Adapt body.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/errout.adb | 50 +-
gcc/ada/errout.ads | 2 +-
gcc/ada/erroutc.adb | 58 +++-
gcc/ada/erroutc.ads | 25 +++
gcc/ada/sem_prag.adb | 2 +-
5 files changed, 69 insertions(+), 68 deletions(-)
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index c4761bd1bc9..4622290897b 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -213,6 +213,10 @@ package body Errout is
-- should have 'Class appended to its name (see Add_Class procedure), and
-- is otherwise unchanged.
+ procedure Validate_Specific_Warnings;
+ -- Checks that specific warnings are consistent (for non-configuration
+ -- case, properly closed, and used).
+
function Warn_Insertion return String;
-- This is called for warning messages only (so Warning_Msg_Char is set)
-- and returns a corresponding string to use at the beginning of generated
@@ -1745,7 +1749,7 @@ package body Errout is
-- do this on the last call, after all possible warnings are posted.
if Last_Call then
- Validate_Specific_Warnings (Error_Msg'Access);
+ Validate_Specific_Warnings;
end if;
end Finalize;
@@ -2001,6 +2005,50 @@ package body Errout is
-- True if S starts with Size_For
end Is_Size_Too_Small_Message;
+
+ -- Validate_Specific_Warnings --
+
+
+ procedure Validate_Specific_Warnings is
+ begin
+ if not Warnsw.Warn_On_Warnings_Off then
+ return;
+ end if;
+
+ for J in Specific_Warnings.First .. Specific_Warnings.Last loop
+ declare
+SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
+
+ begin
+if not SWE.Config then
+
+ -- Warn for unmatched Warnings (Off, ...)
+
+ if SWE.Open then
+ Error_Msg_N
+("?.w?pragma Warnings Off with no matching Warnings On",
+ SWE.Start);
+
+ -- Warn for ineffective Warnings (Off, ..)
+
+ elsif not SWE.Used
+
+ -- Do not issue this warning for -Wxxx messages since the
+ -- back-end doesn't report the information. Note that there
+ -- is always an asterisk at the start of every message.
+
+ and then not
+ (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W")
+ then
+ Error_Msg_N
+("?.w?no warning suppressed by this pragma",
+ SWE.Start);
+ end if;
+end if;
+ end;
+ end loop;
+ end Validate_Specific_Warnings;
+
---
-- Last_Node --
---
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 5a7764aa0a3..089da867d45 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -896,7 +896,7 @@ package Errout is
-- location from which warnings are to be turned back on.
procedure Set_Specific_Warning_Off
- (Loc: Source_Ptr;
+ (Node : Node_Id;
Msg: String;
Reason : String_Id;
Config : Boolean;
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 125cbf822ff..96d8d128d84 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -38,6 +38,7 @@ with Fname;use Fname;
with Namet;use Namet;
with Opt; use Opt;
with Output; use Output;
+with Sinfo.Nodes;
with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;
@@ -1650,15 +1651,16 @@ package body Erroutc is
--
procedure Set_Specific_Warning_Off
- (Loc: Source_Ptr;
+ (Node : Node_Id;
Msg: String;
Reason : String_Id;
Config : Boolean;
Used : Boolean := False)
i
[COMMITTED] ada: Decouple attachment from dynamic allocation for controlled objects
From: Eric Botcazou This decouples the attachment to the appropriate finalization collection of dynamically allocated objects that need finalization from their allocation. The current implementation immediately attaches them after allocating them, which means that they will be finalized even if their initialization does not complete successfully. The new implementation instead generates the same sequence as the one generated for (statically) declared objects, that is to say, allocation, initialization and attachment in this order. gcc/ada/ * exp_ch3.adb (Build_Default_Initialization): Do not generate the protection for finalization collections. (Build_Heap_Or_Pool_Allocator): Set the No_Initialization flag on the declaration of the temporary. * exp_ch4.adb (Build_Aggregate_In_Place): Do not build an allocation procedure here. (Expand_Allocator_Expression): Build an allocation procedure, if it is required, only just before rewriting the allocator. (Expand_N_Allocator): Do not build an allocation procedure if the No_Initialization flag is set on the allocator, except for those generated for special return objects. In other cases, build an allocation procedure, if it is required, only before rewriting the allocator. * exp_ch7.ads (Make_Address_For_Finalize): New function declaration. * exp_ch7.adb (Finalization Management): Update description for dynamically allocated objects. (Make_Address_For_Finalize): Remove declaration. (Find_Last_Init): Change to function and move to... (Process_Object_Declaration): Adjust to above change. * exp_util.ads (Build_Allocate_Deallocate_Proc): Add Mark parameter with Empty default and document it. (Find_Last_Init): New function declaration. * exp_util.adb (Build_Allocate_Deallocate_Proc): Add Mark parameter with Empty default and pass it in recursive call. Deal with type conversions created for interface types. Adjust call sequence to Allocate_Any_Controlled by changing Collection to In/Out parameter and removing Finalize_Address parameter. For a controlled object, generate a conditional call to Attach_Object_To_Collection for an allocation and to Detach_Object_From_Collection for a deallocation. (Find_Last_Init): ...here. Compute the initialization type for an allocator whose designating type is class wide specifically and also handle concurrent types. * rtsfind.ads (RE_Id): Add RE_Attach_Object_To_Collection and RE_Detach_Object_From_Collection. (RE_Unit_Table): Add entries for RE_Attach_Object_To_Collection and RE_Detach_Object_From_Collection. * libgnat/s-finpri.ads (Finalization_Started): Delete. (Attach_Node_To_Collection): Likewise. (Detach_Node_From_Collection): Move to... (Attach_Object_To_Collection): New procedure declaration. (Detach_Object_From_Collection): Likewise. (Finalization_Collection): Remove Atomic for Finalization_Started. Add pragma Inline for Initialize. * libgnat/s-finpri.adb: Add clause for Ada.Unchecked_Conversion. (To_Collection_Node_Ptr): New instance of Ada.Unchecked_Conversion. (Detach_Node_From_Collection): ...here. (Attach_Object_To_Collection): New procedure. (Detach_Object_From_Collection): Likewise. (Finalization_Started): Delete. (Finalize): Replace allocation with attachment in comments. * libgnat/s-stposu.ads (Allocate_Any_Controlled): Rename parameter Context_Subpool into Named_Subpool, parameter Context_Collection into Collection and change it to In/Out, and remove Fin_Address. * libgnat/s-stposu.adb: Remove clause for Ada.Unchecked_Conversion and Finalization_Primitives. (To_Collection_Node_Ptr): Delete. (Allocate_Any_Controlled): Rename parameter Context_Subpool into Named_Subpool, parameter Context_Collection into Collection and change it to In/Out, and remove Fin_Address. Do not lock/unlock and do not attach the object, instead only displace its address. (Deallocate_Any_Controlled): Do not lock/unlock and do not detach the object. (Header_Size_With_Padding): Use qualified name for Header_Size. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 5 +- gcc/ada/exp_ch4.adb | 20 +- gcc/ada/exp_ch7.adb | 370 +++-- gcc/ada/exp_ch7.ads | 7 + gcc/ada/exp_util.adb | 520 --- gcc/ada/exp_util.ads | 25 +- gcc/ada/libgnat/s-finpri.adb | 84 -- gcc/ada/libgnat/s-finpri.ads | 26 +- gcc/ada/libgnat/s-stposu.adb | 196 - gcc/ada/libgnat/s-stposu.ads | 40 ++- gcc/ada/rtsfind.ads
[COMMITTED] ada: Fix pragma Warnings and -gnatD interaction
From: Ronan Desplanques
A recent change broke pragma Warnings when -gnatD is enabled in some
cases. This patch fixes this by caching more slocs at times when it's
known that they haven't been modified by -gnatD.
gcc/ada/
* errout.adb (Validate_Specific_Warnings): Adapt to record
definition change.
* erroutc.adb (Set_Specific_Warning_On, Set_Specific_Warning_Off,
Warning_Specifically_Suppressed): Likewise.
* erroutc.ads: Change record definition.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/errout.adb | 4 ++--
gcc/ada/erroutc.adb | 11 +--
gcc/ada/erroutc.ads | 10 +-
3 files changed, 16 insertions(+), 9 deletions(-)
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index f10539d0949..92c4f6a4635 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -2028,7 +2028,7 @@ package body Errout is
if SWE.Open then
Error_Msg_N
("?.w?pragma Warnings Off with no matching Warnings On",
- SWE.Start);
+ SWE.Node);
-- Warn for ineffective Warnings (Off, ..)
@@ -2043,7 +2043,7 @@ package body Errout is
then
Error_Msg_N
("?.w?no warning suppressed by this pragma",
- SWE.Start);
+ SWE.Node);
end if;
end if;
end;
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 96d8d128d84..be200e0016e 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -1660,9 +1660,10 @@ package body Erroutc is
Loc : constant Source_Ptr := Sinfo.Nodes.Sloc (Node);
begin
Specific_Warnings.Append
-((Start => Node,
+((Start => Loc,
Msg=> new String'(Msg),
Stop => Source_Last (Get_Source_File_Index (Loc)),
+ Node => Node,
Reason => Reason,
Open => True,
Used => Used,
@@ -1682,13 +1683,12 @@ package body Erroutc is
for J in 1 .. Specific_Warnings.Last loop
declare
SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
-Start_Loc : constant Source_Ptr := Sinfo.Nodes.Sloc (SWE.Start);
begin
if Msg = SWE.Msg.all
- and then Loc > Start_Loc
+ and then Loc > SWE.Start
and then SWE.Open
- and then Get_Source_File_Index (Start_Loc) =
+ and then Get_Source_File_Index (SWE.Start) =
Get_Source_File_Index (Loc)
then
SWE.Stop := Loc;
@@ -1819,13 +1819,12 @@ package body Erroutc is
for J in Specific_Warnings.First .. Specific_Warnings.Last loop
declare
SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
-Start_Loc : constant Source_Ptr := Sinfo.Nodes.Sloc (SWE.Start);
begin
-- Pragma applies if it is a configuration pragma, or if the
-- location is in range of a specific non-configuration pragma.
if SWE.Config
- or else Sloc_In_Range (Loc, Start_Loc, SWE.Stop)
+ or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop)
then
if Matches (Msg.all, SWE.Msg.all)
or else Matches (Tag, SWE.Msg.all)
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 250461f4b5c..1c43bce2b21 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -347,11 +347,19 @@ package Erroutc is
-- which is the pattern to match for suppressing a warning.
type Specific_Warning_Entry is record
- Start : Node_Id;
+ Start : Source_Ptr;
Stop : Source_Ptr;
-- Starting and ending source pointers for the range. These are always
-- from the same source file.
+ Node : Node_Id;
+ -- Node for the pragma Warnings occurrence. We store it to compute the
+ -- enclosing subprogram if -gnatdJ is enabled and a message about this
+ -- clause needs to be emitted. Note that we cannot remove the Start
+ -- component above and use Sloc (Node) on message display instead
+ -- because -gnatD output can already have messed with slocs at the point
+ -- when warnings about ineffective clauses are emitted.
+
Reason : String_Id;
-- Reason string from pragma Warnings, or null string if none
--
2.43.2
[COMMITTED] ada: Fix typo in diagnostic message
From: Ronan Desplanques
A previous change introduced an error in the diagnostic message about
overlapping actuals. This commit fixes this.
gcc/ada/
* sem_warn.adb (Warn_On_Overlapping_Actuals): Fix typo.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_warn.adb | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index ccf9067c672..2de3f8668b0 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -3865,7 +3865,7 @@ package body Sem_Warn is
-- This is one of the messages
Error_Msg_FE ("<.i
[COMMITTED] ada: Fix crash with -gnatdJ and -gnatyz
From: Ronan Desplanques
This patch makes it so -gnatyz style checks reports specify a node
ID. That is required since those checks are sometimes made during
semantic analysis of short-circuit operators, where the Current_Node
mechanism that -gnatdJ uses is not operational.
Check_Xtra_Parens_Precedence is moved from Styleg to Style to make
this possible.
gcc/ada/
* styleg.ads (Check_Xtra_Parens_Precedence): Moved ...
* style.ads (Check_Xtra_Parens_Precedence): ... here. Also
replace corresponding renaming.
* styleg.adb (Check_Xtra_Parens_Precedence): Moved ...
* style.adb (Check_Xtra_Parens_Precedence): here. Also use
Errout.Error_Msg and pass it a node parameter.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/style.adb | 22 ++
gcc/ada/style.ads | 3 +--
gcc/ada/styleg.adb | 22 --
gcc/ada/styleg.ads | 4
4 files changed, 23 insertions(+), 28 deletions(-)
diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb
index aaa668aab00..18b110b911d 100644
--- a/gcc/ada/style.adb
+++ b/gcc/ada/style.adb
@@ -337,6 +337,28 @@ package body Style is
end if;
end Check_Identifier;
+ --
+ -- Check_Xtra_Parens_Precedence --
+ --
+
+ procedure Check_Xtra_Parens_Precedence (N : Node_Id) is
+ begin
+ if Style_Check_Xtra_Parens_Precedence
+and then
+ Paren_Count (N) >
+(if Nkind (N) in N_Case_Expression
+ | N_Expression_With_Actions
+ | N_If_Expression
+ | N_Quantified_Expression
+ | N_Raise_Expression
+ then 1
+ else 0)
+ then
+ Error_Msg -- CODEFIX
+ ("(style) redundant parentheses?z?", First_Sloc (N), N);
+ end if;
+ end Check_Xtra_Parens_Precedence;
+
-- Missing_Overriding --
diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads
index c0925e9ce34..9614242269c 100644
--- a/gcc/ada/style.ads
+++ b/gcc/ada/style.ads
@@ -196,8 +196,7 @@ package Style is
-- Called after scanning an entire expression (N) that does not require an
-- extra level of parentheses.
- procedure Check_Xtra_Parens_Precedence (N : Node_Id)
- renames Style_Inst.Check_Xtra_Parens_Precedence;
+ procedure Check_Xtra_Parens_Precedence (N : Node_Id);
-- Called after scanning a subexpression (N) that does not require an
-- extra level of parentheses according to operator precedence rules.
diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb
index 287589f92da..c405dec2b33 100644
--- a/gcc/ada/styleg.adb
+++ b/gcc/ada/styleg.adb
@@ -1054,28 +1054,6 @@ package body Styleg is
end if;
end Check_Xtra_Parens;
- --
- -- Check_Xtra_Parens_Precedence --
- --
-
- procedure Check_Xtra_Parens_Precedence (N : Node_Id) is
- begin
- if Style_Check_Xtra_Parens_Precedence
-and then
- Paren_Count (N) >
-(if Nkind (N) in N_Case_Expression
- | N_Expression_With_Actions
- | N_If_Expression
- | N_Quantified_Expression
- | N_Raise_Expression
- then 1
- else 0)
- then
- Error_Msg -- CODEFIX
- ("(style) redundant parentheses?z?", Errout.First_Sloc (N));
- end if;
- end Check_Xtra_Parens_Precedence;
-
-- Determine_Token_Casing --
diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads
index 9028e85cc4e..a16ea5c5961 100644
--- a/gcc/ada/styleg.ads
+++ b/gcc/ada/styleg.ads
@@ -160,10 +160,6 @@ package Styleg is
-- Called after scanning an entire expression (N) that does not require an
-- extra level of parentheses.
- procedure Check_Xtra_Parens_Precedence (N : Node_Id);
- -- Called after scanning a subexpression (N) that does not require an
- -- extra level of parentheses according to operator precedence rules.
-
function Mode_In_Check return Boolean;
pragma Inline (Mode_In_Check);
-- Determines whether style checking is active and the Mode_In_Check is
--
2.43.2
[COMMITTED] ada: Fix pragma Compile_Time_Error and -gnatdJ crash
From: Ronan Desplanques
This patch makes it so the diagnostics coming from occurrences of
pragma Compile_Time_Error and Compile_Time_Warning are emitted with
a node parameter so they don't cause a crash when -gnatdJ is enabled.
gcc/ada/
* errout.ads (Error_Msg): Add node parameter.
* errout.adb (Error_Msg): Add parameter and pass it to
the underlying call.
* sem_prag.adb (Validate_Compile_Time_Warning_Or_Error): Pass
pragma node when emitting errors.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/errout.adb | 3 ++-
gcc/ada/errout.ads | 7 ---
gcc/ada/sem_prag.adb | 8
3 files changed, 10 insertions(+), 8 deletions(-)
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 4622290897b..f10539d0949 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -325,12 +325,13 @@ package body Errout is
procedure Error_Msg
(Msg : String;
Flag_Location : Source_Ptr;
+ N : Node_Id;
Is_Compile_Time_Pragma : Boolean)
is
Save_Is_Compile_Time_Msg : constant Boolean := Is_Compile_Time_Msg;
begin
Is_Compile_Time_Msg := Is_Compile_Time_Pragma;
- Error_Msg (Msg, To_Span (Flag_Location), Current_Node);
+ Error_Msg (Msg, To_Span (Flag_Location), N);
Is_Compile_Time_Msg := Save_Is_Compile_Time_Msg;
end Error_Msg;
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 089da867d45..f0e3f5d0b7c 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -738,10 +738,11 @@ package Errout is
procedure Error_Msg
(Msg: String;
Flag_Location : Source_Ptr;
+ N : Node_Id;
Is_Compile_Time_Pragma : Boolean);
- -- Same as Error_Msg (String, Source_Ptr) except Is_Compile_Time_Pragma
- -- lets the caller specify whether this is a Compile_Time_Warning or
- -- Compile_Time_Error pragma.
+ -- Same as Error_Msg (String, Source_Ptr, Node_Id) except
+ -- Is_Compile_Time_Pragma lets the caller specify whether this is a
+ -- Compile_Time_Warning or Compile_Time_Error pragma.
procedure Error_Msg_S (Msg : String);
-- Output a message at current scan pointer location. This routine can be
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index dfc415da3f3..9646e891c46 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -33145,11 +33145,11 @@ package body Sem_Prag is
if Force then
if Cont = False then
Error_Msg
- ("<<~!!", Eloc, Is_Compile_Time_Pragma => True);
+ ("<<~!!", Eloc, N, Is_Compile_Time_Pragma => True);
Cont := True;
else
Error_Msg
- ("\<<~!!", Eloc, Is_Compile_Time_Pragma => True);
+ ("\<<~!!", Eloc, N, Is_Compile_Time_Pragma => True);
end if;
-- Error, rather than warning, or in a body, so we do not
@@ -33161,11 +33161,11 @@ package body Sem_Prag is
else
if Cont = False then
Error_Msg
- ("<<~", Eloc, Is_Compile_Time_Pragma => True);
+ ("<<~", Eloc, N, Is_Compile_Time_Pragma => True);
Cont := True;
else
Error_Msg
- ("\<<~", Eloc, Is_Compile_Time_Pragma => True);
+ ("\<<~", Eloc, N, Is_Compile_Time_Pragma => True);
end if;
end if;
--
2.43.2
[COMMITTED] ada: Fix crash with -gnatdJ and JSON output
From: Ronan Desplanques
This patch tweaks the calls made to Errout subprograms to report
violations of dependence restrictions, in order fix a crash that
occurred with -gnatdJ and -fdiagnostics-format=json.
gcc/ada/
* restrict.adb (Violation_Of_No_Dependence): Tweak error
reporting calls.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/restrict.adb | 12 ++--
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index 1cc75bec326..bda35d8f441 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -1704,16 +1704,16 @@ package body Restrict is
procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id) is
+ Unit_Node : constant Node_Id := No_Dependences.Table (Unit).Unit;
begin
- Error_Msg_Node_1 := No_Dependences.Table (Unit).Unit;
- Error_Msg_Sloc := Sloc (Error_Msg_Node_1);
+ Error_Msg_Sloc := Sloc (Unit_Node);
if No_Dependences.Table (Unit).Warn then
- Error_Msg
- ("?*?violation of restriction `No_Dependence '='> &`#", Sloc (N));
+ Error_Msg_NE ("?*?violation of restriction `No_Dependence '='> &`#",
+ N, Unit_Node);
else
- Error_Msg
- ("|violation of restriction `No_Dependence '='> &`#", Sloc (N));
+ Error_Msg_NE ("|violation of restriction `No_Dependence '='> &`#", N,
+ Unit_Node);
end if;
end Violation_Of_No_Dependence;
--
2.43.2
[COMMITTED] ada: Replace "not Present" tests with "No".
From: Steve Baird Fix constructs that were flagged by CodePeer. gcc/ada/ * exp_attr.adb: Replace 6 "not Present" tests with equivalent calls to "No". Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_attr.adb | 12 ++-- 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b7277118a9c..6dba600620e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4334,7 +4334,7 @@ package body Exp_Attr is Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input, N); - if not Present (Fname) then + if No (Fname) then -- If there is a Stream_Convert pragma, use it, we rewrite @@ -5422,7 +5422,7 @@ package body Exp_Attr is Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output, N); - if not Present (Pname) then + if No (Pname) then -- If there is a Stream_Convert pragma, use it, we rewrite @@ -5998,7 +5998,7 @@ package body Exp_Attr is Pname := Cached_Attribute_Ops.Put_Image_Map.Get (U_Type); Cached_Attribute_Ops.Validate_Cached_Candidate (Pname, Attr_Ref => N); - if not Present (Pname) then + if No (Pname) then declare procedure Build_And_Insert_Array_Put_Image_Proc is new Build_And_Insert_Type_Attr_Subp @@ -6052,7 +6052,7 @@ package body Exp_Attr is Pname := Cached_Attribute_Ops.Put_Image_Map.Get (Base_Typ); Cached_Attribute_Ops.Validate_Cached_Candidate (Pname, Attr_Ref => N); - if not Present (Pname) then + if No (Pname) then declare procedure Build_And_Insert_Record_Put_Image_Proc is new Build_And_Insert_Type_Attr_Subp @@ -6352,7 +6352,7 @@ package body Exp_Attr is Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read, N); - if not Present (Pname) then + if No (Pname) then -- If there is a Stream_Convert pragma, use it, we rewrite @@ -8067,7 +8067,7 @@ package body Exp_Attr is Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write, N); - if not Present (Pname) then + if No (Pname) then -- If there is a Stream_Convert pragma, use it, we rewrite -- 2.43.2
[COMMITTED] ada: Fix warning indicators in usage string
From: Ronan Desplanques
Before this patch, the default status of -gnatw.i and -gnatw.d are
reported incorrectly in the usage string used throughout GNAT tools.
This patch fixes this.
gcc/ada/
* usage.adb (Usage): Fix enabled-by-default indicators.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/usage.adb | 8
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb
index 85b371ac4f1..59cbd6f4a2f 100644
--- a/gcc/ada/usage.adb
+++ b/gcc/ada/usage.adb
@@ -498,8 +498,8 @@ begin
"Compile_Time_Warning");
Write_Line ("dturn on warnings for implicit dereference");
Write_Line ("D* turn off warnings for implicit dereference");
- Write_Line (".d turn on tagging of warnings with -gnatw switch");
- Write_Line (".D* turn off tagging of warnings with -gnatw switch");
+ Write_Line (".d* turn on tagging of warnings with -gnatw switch");
+ Write_Line (".D turn off tagging of warnings with -gnatw switch");
Write_Line ("etreat all warnings (but not info) as errors");
Write_Line (".e turn on every optional info/warning " &
"(no exceptions)");
@@ -517,8 +517,8 @@ begin
Write_Line (".H* turn off warnings for holes in records");
Write_Line ("i*+ turn on warnings for implementation unit");
Write_Line ("Iturn off warnings for implementation unit");
- Write_Line (".i*+ turn on warnings for overlapping actuals");
- Write_Line (".I turn off warnings for overlapping actuals");
+ Write_Line (".i+ turn on warnings for overlapping actuals");
+ Write_Line (".I* turn off warnings for overlapping actuals");
Write_Line ("j+ turn on warnings for obsolescent " &
"(annex J) feature");
Write_Line ("J* turn off warnings for obsolescent " &
--
2.43.2
[COMMITTED] ada: Minor typo fix in comment
gcc/ada/ * sem_util.adb: Typo fix in comment. * exp_aggr.adb: Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 2 +- gcc/ada/sem_util.adb | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 27a7f3d2b49..bdaca4aab58 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1988,7 +1988,7 @@ package body Exp_Aggr is -- STEP 1: Process component associations -- For those associations that may generate a loop, initialize - -- Loop_Actions to collect inserted actions that may be crated. + -- Loop_Actions to collect inserted actions that may be created. -- Skip this if no component associations diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4e1258e7cec..1785931530f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7785,7 +7785,7 @@ package body Sem_Util is Set_Is_Immediately_Visible (E, False); -- Case of renaming declaration constructed for package instances. - -- if there is an explicit declaration with the same identifier, + -- If there is an explicit declaration with the same identifier, -- the renaming is not immediately visible any longer, but remains -- visible through selected component notation. @@ -7794,7 +7794,7 @@ package body Sem_Util is then Set_Is_Immediately_Visible (E, False); - -- The new entity may be the package renaming, which has the same + -- The new entity may be the package renaming, which has the -- same name as a generic formal which has been seen already. elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration -- 2.43.2
[COMMITTED] ada: Follow-up adjustment after fix to Default_Initialize_Object
From: Eric Botcazou Now that Default_Initialize_Object honors the No_Initialization flag in all cases, objects of an access type declared without initialization expression can no longer be considered as being automatically initialized to null. gcc/ada/ * exp_ch3.adb (Expand_N_Object_Declaration): Examine the Expression field after the call to Default_Initialize_Object in order to set Is_Known_Null, as well as Is_Known_Non_Null, on an access object. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 16 ++-- 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e34cb8fb58f..9109d592690 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7604,6 +7604,16 @@ package body Exp_Ch3 is if not Special_Ret_Obj then Default_Initialize_Object (Init_After); + +-- Check whether an access object has been initialized above + +if Is_Access_Type (Typ) and then Present (Expression (N)) then + if Known_Non_Null (Expression (N)) then + Set_Is_Known_Non_Null (Def_Id); + elsif Known_Null (Expression (N)) then + Set_Is_Known_Null (Def_Id); + end if; +end if; end if; -- Generate attribute for Persistent_BSS if needed @@ -7625,12 +7635,6 @@ package body Exp_Ch3 is end; end if; - -- If access type, then we know it is null if not initialized - - if Is_Access_Type (Typ) then -Set_Is_Known_Null (Def_Id); - end if; - -- Explicit initialization present else -- 2.43.2
[COMMITTED] ada: Restore default size for dynamic allocations of discriminated type
From: Eric Botcazou The allocation strategy for objects of a discriminated type with defaulted discriminants is not the same when the allocation is dynamic as when it is static (i.e a declaration): in the former case, the compiler allocates the default size whereas, in the latter case, it allocates the maximum size. This restores the default size, which was dropped during the refactoring. gcc/ada/ * exp_aggr.adb (Build_Array_Aggr_Code): Pass N in the call to Build_Initialization_Call. (Build_Record_Aggr_Code): Likewise. (Convert_Aggr_In_Object_Decl): Likewise. (Initialize_Discriminants): Likewise. * exp_ch3.ads (Build_Initialization_Call): Replace Loc witn N. * exp_ch3.adb (Build_Array_Init_Proc): Pass N in the call to Build_Initialization_Call. (Build_Default_Initialization): Likewise. (Expand_N_Object_Declaration): Likewise. (Build_Initialization_Call): Replace Loc witn N parameter and add Loc local variable. Build a default subtype for an allocator of a discriminated type with defaulted discriminants. (Build_Record_Init_Proc): Pass the declaration of components in the call to Build_Initialization_Call. * exp_ch6.adb (Make_CPP_Constructor_Call_In_Allocator): Pass the allocator in the call to Build_Initialization_Call. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 18 -- gcc/ada/exp_ch3.adb | 37 - gcc/ada/exp_ch3.ads | 4 ++-- gcc/ada/exp_ch6.adb | 2 +- 4 files changed, 39 insertions(+), 22 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 86f304e90bb..a4e4d81f0a8 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1493,7 +1493,7 @@ package body Exp_Aggr is or else Has_Task (Base_Type (Ctype)) then Append_List_To (Stmts, - Build_Initialization_Call (Loc, + Build_Initialization_Call (N, Id_Ref=> Indexed_Comp, Typ => Ctype, With_Default_Init => True)); @@ -2936,7 +2936,7 @@ package body Exp_Aggr is if not Is_Interface (Init_Typ) then Append_List_To (L, -Build_Initialization_Call (Loc, +Build_Initialization_Call (N, Id_Ref=> Ref, Typ => Init_Typ, In_Init_Proc => Within_Init_Proc, @@ -2971,7 +2971,7 @@ package body Exp_Aggr is Set_Assignment_OK (Ref); Append_List_To (L, - Build_Initialization_Call (Loc, + Build_Initialization_Call (N, Id_Ref=> Ref, Typ => Init_Typ, In_Init_Proc => Within_Init_Proc, @@ -3148,7 +3148,7 @@ package body Exp_Aggr is if Is_CPP_Constructor_Call (Expression (Comp)) then Append_List_To (L, - Build_Initialization_Call (Loc, + Build_Initialization_Call (N, Id_Ref=> Make_Selected_Component (Loc, Prefix=> New_Copy_Tree (Target), @@ -3217,7 +3217,7 @@ package body Exp_Aggr is end; Append_List_To (L, - Build_Initialization_Call (Loc, + Build_Initialization_Call (N, Id_Ref=> Make_Selected_Component (Loc, Prefix=> New_Copy_Tree (Target), Selector_Name => @@ -3747,8 +3747,8 @@ package body Exp_Aggr is Param := First (Parameter_Associations (Stmt)); Insert_Actions (Stmt, - Build_Initialization_Call - (Sloc (N), New_Copy_Tree (Param), Etype (Param))); + Build_Initialization_Call (N, + New_Copy_Tree (Param), Etype (Param))); end if; Next (Stmt); @@ -9279,13 +9279,11 @@ package body Exp_Aggr is Present (Variant_Part (Component_List (Type_Definition (Decl and then Nkind (N) /= N_Extension_Aggregate then - -- Call init proc to set discriminants. -- There should eventually be a special procedure for this ??? Ref := New_Occurrence_Of (Defining_Identifier (N), Loc); - Insert_Actions_After (N, - Build_Initialization_Call (Sloc (N), Ref, Typ)); + Insert_Actions_After (N, Build_Initialization_Call (N, Ref, Typ)); end if; end Initialize_Discriminants; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 9109d592690..13a0c8e7500 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc
[COMMITTED] ada: Better error message for bad general case statements
From: Steve Baird
If -gnatX0 is specified, we allow case statements with a selector
expression of a record or array type, but not of a private type.
If the selector expression is of a private type then we should generate
an appropriate error message instead of a bugbox.
gcc/ada/
* sem_ch5.adb (Analyze_Case_Statement): Emit a message and return
early in the case where general case statements are allowed but
the selector expression is of a private type. This is done to
avoid a bugbox.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch5.adb | 9 +
1 file changed, 9 insertions(+)
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 2677a2c5a1c..65370ebfe7e 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -1497,6 +1497,15 @@ package body Sem_Ch5 is
Resolve (Exp, Etype (Exp));
Exp_Type := Etype (Exp);
Is_General_Case_Statement := True;
+ if not (Is_Record_Type (Exp_Type) or Is_Array_Type (Exp_Type)) then
+Error_Msg_N
+ ("selecting expression of general case statement " &
+ "must be a record or an array",
+ Exp);
+
+-- Avoid cascading errors
+return;
+ end if;
else
Analyze_And_Resolve (Exp, Any_Discrete);
Exp_Type := Etype (Exp);
--
2.43.2
[COMMITTED] ada: Small cleanup about allocators and aggregates
From: Eric Botcazou This eliminates a few oddities present in the expander for allocators and aggregates present in allocators: - Convert_Array_Aggr_In_Allocator takes both a Decl and Alloc parameters, and inserts new code before Alloc for records and after Decl for arrays through Convert_Array_Aggr_In_Allocator. Now, for the 3 (duplicated) calls to the procedure, that's the same place. It also creates a new list that it does not use in most cases. - Expand_Allocator_Expression uses the same code sequence in 3 places when the expression is an aggregate to build in place. - Build_Allocate_Deallocate_Proc takes an Is_Allocate parameter that is entirely determined by the N parameter: if N is an allocator, it must be true; if N is a free statement, it must be false. Barring that, the procedure either raises an assertion or Program_Error. It also contains useless pattern matching code in the second part. No functional changes. gcc/ada/ * exp_aggr.ads (Convert_Aggr_In_Allocator): Rename Alloc into N, replace Decl with Temp and adjust description. (Convert_Aggr_In_Object_Decl): Alphabetize. (Is_Delayed_Aggregate): Likewise. * exp_aggr.adb (Convert_Aggr_In_Allocator): Rename Alloc into N and replace Decl with Temp. Allocate a list only when neeeded. (Convert_Array_Aggr_In_Allocator): Replace N with Decl and insert new code before it. * exp_ch4.adb (Build_Aggregate_In_Place): New procedure nested in Expand_Allocator_Expression. (Expand_Allocator_Expression): Call it to build aggregates in place. Remove second parameter in calls to Build_Allocate_Deallocate_Proc. (Expand_N_Allocator): Likewise. * exp_ch13.adb (Expand_N_Free_Statement): Likewise. * exp_util.ads (Build_Allocate_Deallocate_Proc): Remove Is_Allocate parameter. * exp_util.adb (Build_Allocate_Deallocate_Proc): Remove Is_Allocate parameter and replace it with local variable of same name. Delete useless pattern matching. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 34 ++-- gcc/ada/exp_aggr.ads | 33 ++-- gcc/ada/exp_ch13.adb | 2 +- gcc/ada/exp_ch4.adb | 123 ++- gcc/ada/exp_util.adb | 48 ++--- gcc/ada/exp_util.ads | 7 +-- 6 files changed, 102 insertions(+), 145 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index a4e4d81f0a8..27a7f3d2b49 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -283,7 +283,7 @@ package body Exp_Aggr is --are writing into. procedure Convert_Array_Aggr_In_Allocator - (Decl : Node_Id; + (N : Node_Id; Aggr : Node_Id; Target : Node_Id); -- If the aggregate appears within an allocator and can be expanded in @@ -3542,13 +3542,12 @@ package body Exp_Aggr is --- procedure Convert_Aggr_In_Allocator - (Alloc : Node_Id; - Decl : Node_Id; - Aggr : Node_Id) + (N: Node_Id; + Aggr : Node_Id; + Temp : Entity_Id) is Loc : constant Source_Ptr := Sloc (Aggr); Typ : constant Entity_Id := Etype (Aggr); - Temp : constant Entity_Id := Defining_Identifier (Decl); Occ : constant Node_Id := Unchecked_Convert_To (Typ, @@ -3556,26 +3555,29 @@ package body Exp_Aggr is begin if Is_Array_Type (Typ) then - Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ); + Convert_Array_Aggr_In_Allocator (N, Aggr, Occ); elsif Has_Default_Init_Comps (Aggr) then declare -L : constant List_Id := New_List; -Init_Stmts : List_Id; +Init_Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ); begin -Init_Stmts := Late_Expansion (Aggr, Typ, Occ); - if Has_Task (Typ) then - Build_Task_Allocate_Block (L, Aggr, Init_Stmts); - Insert_Actions (Alloc, L); + declare + Actions : constant List_Id := New_List; + + begin + Build_Task_Allocate_Block (Actions, Aggr, Init_Stmts); + Insert_Actions (N, Actions); + end; + else - Insert_Actions (Alloc, Init_Stmts); + Insert_Actions (N, Init_Stmts); end if; end; else - Insert_Actions (Alloc, Late_Expansion (Aggr, Typ, Occ)); + Insert_Actions (N, Late_Expansion (Aggr, Typ, Occ)); end if; end Convert_Aggr_In_Allocator; @@ -3774,7 +3776,7 @@ package body Exp_Aggr is - procedure Convert_Array_Aggr_In_Allocator - (Decl : Node_Id; + (N : Node_Id; Aggr : Node_Id; Target : Node_Id) is @@ -3829,7 +3831,7 @@ pa
[COMMITTED] ada: Fix overlap warning suppression
From: Ronan Desplanques
Before this patch, some warnings about overlapping actuals were
emitted regardless of the Value of
Warnsw.Warnings_Package.Warn_On_Overlap. This patch fixes this.
gcc/ada/
* sem_warn.adb (Warn_On_Overlapping_Actuals): Stop ignoring
warning suppression settings.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_warn.adb | 33 +
1 file changed, 13 insertions(+), 20 deletions(-)
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 57bdee65356..ccf9067c672 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -3831,16 +3831,6 @@ package body Sem_Warn is
then
null;
- -- We only report warnings on overlapping arrays and record
- -- types if switch is set.
-
- elsif not Warn_On_Overlap
-and then not (Is_Elementary_Type (Etype (Form1))
-and then
- Is_Elementary_Type (Etype (Form2)))
- then
- null;
-
-- Here we may need to issue overlap message
else
@@ -3858,22 +3848,25 @@ package body Sem_Warn is
or else not
(Is_Elementary_Type (Etype (Form1))
- and then Is_Elementary_Type (Etype (Form2)))
+ and then Is_Elementary_Type (Etype (Form2)));
- -- debug flag -gnatd.E changes the error to a warning
- -- even in Ada 2012 mode.
+ if not Error_Msg_Warn or else Warn_On_Overlap then
+-- debug flag -gnatd.E changes the error to a warning
+-- even in Ada 2012 mode.
- or else Error_To_Warning;
+if Error_To_Warning then
+ Error_Msg_Warn := True;
+end if;
- -- For greater clarity, give name of formal
+-- For greater clarity, give name of formal
- Error_Msg_Node_2 := Form2;
+Error_Msg_Node_2 := Form2;
- -- This is one of the messages
+-- This is one of the messages
- Error_Msg_FE
- ("<.i
[COMMITTED] ada: Reduce generated code duplication for streaming and Put_Image subprograms
From: Steve Baird In the case of an untagged composite type, the compiler does not generate streaming-related subprograms or a Put_Image procedure when the type is declared. Instead, these subprograms are declared "on demand" when a corresponding attribute reference is encountered. In this case, hoist the declaration of the implicitly declared subprogram out as far as possible in order to maximize the chances that it can be reused (as opposed to generating an identical second subprogram) in the case where a second reference to the same attribute is encountered. Also relax some privacy-related rules to allow these procedures to do what they need to do even when constructed in a scope where some of those actions would normally be illegal. gcc/ada/ * exp_attr.adb: Change name of package Cached_Streaming_Ops to reflect the fact that it is now also used for Put_Image procedures. Similarly change other "Streaming_Op" names therein. Add Validate_Cached_Candidate procedure to detect case where a subprogram found in the cache cannot be reused. Add new generic procedure Build_And_Insert_Type_Attr_Subp; the "Build" part is handled by just calling a formal procedure; the bulk of this (generic) procedure's code has to with deciding where in the tree to insert the newly-constructed subprogram. Replace each later "Build" call (and the following Insert_Action or Compile_Stream_Body_In_Scope call) with a declare block that instantiates and then calls this generic procedure. Delete the now-unused procedure Compile_Stream_Body_In_Scope. A constructed subprogram is entered in the appropriate cache if the corresponding type is untagged; this replaces more complex tests. A new function Interunit_Ref_OK is added to determine whether an attribute reference occuring in one unit can safely refer to a cached subprogram declared in another unit. * exp_ch3.adb (Build_Predefined_Primitive_Bodies): A formal parameter was deleted, so delete the corresponding actual in a call. * exp_put_image.adb (Build_Array_Put_Image_Procedure): Because the procedure being built may be referenced more than once, the generated procedure takes its source position info from the type declaration instead of the (first) attribute reference. (Build_Record_Put_Image_Procedure): Likewise. * exp_put_image.ads (Build_Array_Put_Image_Procedure): Eliminate now-unused Nod parameter. (Build_Record_Put_Image_Procedure): Eliminate now-unused Loc parameter. * sem_ch3.adb (Constrain_Discriminated_Type): For declaring a subtype with a discriminant constraint, ignore privacy if Comes_From_Source is false (as is already done if Is_Instance is true). * sem_res.adb (Resolve): When passed two type entities that have the same underlying base type, Sem_Type.Covers may return False in some cases because of privacy. [This can happen even if Is_Private_Type returns False both for Etype (N) and for Typ; Covers calls Base_Type, which can take a non-private argument and yield a private result.] If Comes_From_Source (N) is False (e.g., for a compiler-generated Put_Image or streaming subprogram), then avoid that scenario by not calling Covers. Covers already has tests for doing this sort of thing (see the calls therein to Full_View_Covers), but the Comes_From_Source test is too coarse to apply there. So instead we handle the problem here at the call site. (Original_Implementation_Base_Type): A new function. Same as Implementation_Base_Type except if the Original_Node attribute of a non-derived type declaration indicates that it once was a derived type declaration. Needed for looking through privacy. (Valid Conversion): Ignore privacy when converting between different views of the same type if Comes_From_Source is False for the conversion. (Valid_Tagged_Conversion): An ancestor-to-descendant conversion is not an illegal downward conversion if there is no type extension involved (because the derivation was from an untagged view of the parent type). Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_attr.adb | 627 -- gcc/ada/exp_ch3.adb | 2 +- gcc/ada/exp_put_image.adb | 13 +- gcc/ada/exp_put_image.ads | 8 +- gcc/ada/sem_ch3.adb | 5 +- gcc/ada/sem_res.adb | 79 - 6 files changed, 484 insertions(+), 250 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 809116d89e3..b7277118a9c 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -80,12 +80,12 @@ with GNAT.HTable; package body Exp_Attr is - package Cached_Streaming_Ops is + packag
[COMMITTED] ada: Fix crash with -gnatdJ and -gnatf
From: Ronan Desplanques
This patch fixes a crash when the compiler emits a warning about
an unchecked conversion and -gnatdJ is enabled.
gcc/ada/
* sem_ch13.adb (Validate_Unchecked_Conversions): Add node
parameters to Error_Msg calls.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch13.adb | 9 +
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 0470ce10ac7..1ad5c4c0128 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -18401,7 +18401,8 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := Source_Siz;
Error_Msg_Name_2 := Chars (Target);
Error_Msg_Uint_2 := Target_Siz;
- Error_Msg ("\size of % is ^, size of % is ^?z?", Eloc);
+ Error_Msg
+ ("\size of % is ^, size of % is ^?z?", Eloc, Act_Unit);
Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
@@ -18412,17 +18413,17 @@ package body Sem_Ch13 is
if Source_Siz > Target_Siz then
Error_Msg
("\?z?^ high order bits of source will "
- & "be ignored!", Eloc);
+ & "be ignored!", Eloc, Act_Unit);
elsif Is_Unsigned_Type (Source) then
Error_Msg
("\?z?source will be extended with ^ high order "
- & "zero bits!", Eloc);
+ & "zero bits!", Eloc, Act_Unit);
else
Error_Msg
("\?z?source will be extended with ^ high order "
- & "sign bits!", Eloc);
+ & "sign bits!", Eloc, Act_Unit);
end if;
elsif Source_Siz < Target_Siz then
--
2.43.2
[COMMITTED] ada: Rtsfind should not trash state used in analyzing instantiations.
From: Steve Baird During analysis of an instantiation, Sem_Ch12 manages formal/actual binding information in package state (see Sem_Ch12.Generic_Renamings_HTable). A call to rtsfind can cause another unit to be loaded and compiled. If this occurs during the analysis of an instantiation, and if the loaded unit contains a second instantiation, then the Sem_Ch12 state needed for analyzing the first instantiation can be trashed during the analysis of the second instantiation. Rtsfind calls that can include the analysis of an instantiation need to save and restore Sem_Ch12's state. gcc/ada/ * sem_ch12.ads: Declare new Instance_Context package, which declares a private type Context with operations Save_And_Reset and Restore. * sem_ch12.adb: Provide body for new Instance_Context package. * rtsfind.adb (Load_RTU): Wrap an Instance_Context Save/Restore call pair around the call to Semantics. * table.ads: Add initial value for Last_Val (because Save_And_Reset expects Last_Val to be initialized). Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/rtsfind.adb | 9 ++- gcc/ada/sem_ch12.adb | 62 gcc/ada/sem_ch12.ads | 25 ++ gcc/ada/table.ads| 2 +- 4 files changed, 96 insertions(+), 2 deletions(-) diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 8933ca6ce16..7c9935e614c 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -47,6 +47,7 @@ with Restrict; use Restrict; with Sem;use Sem; with Sem_Aux;use Sem_Aux; with Sem_Ch7;use Sem_Ch7; +with Sem_Ch12;use Sem_Ch12; with Sem_Dist; use Sem_Dist; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -1185,7 +1186,13 @@ package body Rtsfind is else Save_Private_Visibility; - Semantics (Cunit (U.Unum)); + declare + Saved_Instance_Context : constant Instance_Context.Context +:= Instance_Context.Save_And_Reset; + begin + Semantics (Cunit (U.Unum)); + Instance_Context.Restore (Saved_Instance_Context); + end; Restore_Private_Visibility; if Fatal_Error (U.Unum) = Error_Detected then diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index cb05a71e96f..4ceddda2052 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -17753,4 +17753,66 @@ package body Sem_Ch12 is raise Program_Error; end case; end Validate_Formal_Type_Default; + + package body Instance_Context is + + + -- Save_And_Reset -- + + + function Save_And_Reset return Context is + begin + return Result : Context (0 .. Integer (Generic_Renamings.Last)) do +for Index in Result'Range loop + declare + Indexed_Assoc : Assoc renames Generic_Renamings.Table + (Assoc_Ptr (Index)); + Result_Pair : Binding_Pair renames Result (Index); + begin + -- If we have called Increment_Last but have not yet + -- initialized the new last element of the table, then + -- that last element might be invalid. Saving and + -- restoring (especially restoring, it turns out) invalid + -- values can result in exceptions if predicate checking + -- is enabled, so replace invalid values with Empty. + + if Indexed_Assoc.Gen_Id'Valid then + Result_Pair.Formal_Id := Indexed_Assoc.Gen_Id; + else + pragma Assert (Index = Result'Last); + Result_Pair.Formal_Id := Empty; + end if; + + if Indexed_Assoc.Act_Id'Valid then + Result_Pair.Actual_Id := Indexed_Assoc.Act_Id; + else + pragma Assert (Index = Result'Last); + Result_Pair.Actual_Id := Empty; + end if; + end; +end loop; + +Generic_Renamings.Init; +Generic_Renamings.Set_Last (0); +Generic_Renamings_HTable.Reset; + end return; + end Save_And_Reset; + + - + -- Restore -- + - + + procedure Restore (Saved : Context) is + begin + Generic_Renamings.Init; + Generic_Renamings.Set_Last (0); + Generic_Renamings_HTable.Reset; + Generic_Renamings.Increment_Last; + for Pair of Saved loop +Set_Instance_Of (Pair.Formal_Id, Pair.Actual_Id); + end loop; + Generic_Renamings.Decrement_Last; + end Restore; + + end Instance_Context; end Sem_Ch12; d
[COMMITTED] ada: Compiler crash or errors on if_expression in container aggregate
From: Gary Dismukes The compiler may either crash or incorrectly report errors when a component association in a container aggregate is an if_expression with an elsif part whose dependent expression is a call to a function returning a result that requires finalization. The compiler complains that a private type is expected, but a package or procedure name was found. This is due to the compiler improperly associating expanded calls to Finalize_Object with the aggregate, rather than the enclosing object declaration being initialized by the aggregate, which can result in the Finalize_Object procedure call being passed as an actual to the Add_Unnamed operation of the container type and leading to a type mismatch and the confusing error message. This is fixed by adjusting the code that locates the proper context for insertion of Finalize_Object calls to locate the enclosing declaration or statement rather than stopping at the aggregate. gcc/ada/ * exp_util.adb (Find_Hook_Context): Exclude N_*Aggregate Nkinds of Parent (Par) from the early return in the second loop of the In_Cond_Expr case, to prevent returning an aggregate from this function rather than the enclosing declaration or statement. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_util.adb | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4b1c5322f62..d9623e2ea40 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6412,7 +6412,9 @@ package body Exp_Util is and then Nkind (Parent (Par)) not in N_Function_Call | N_Procedure_Call_Statement | N_Entry_Call_Statement - + | N_Aggregate + | N_Delta_Aggregate + | N_Extension_Aggregate then return Par; -- 2.43.2
[COMMITTED] ada: Error in determining accumulator subtype for a reduction expression
From: Steve Baird There was an earlier bug in determining the accumulator subtype for a reduction expression in the case where the reducer subprogram is overloaded. The fix for that bug introduced a recently-discovered regression. Redo accumulator subtype computation in order to address this regression while preserving the benefits of the earlier fix. gcc/ada/ * exp_attr.adb: Move computation of Accum_Typ entirely into the function Build_Stat. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_attr.adb | 65 ++-- 1 file changed, 26 insertions(+), 39 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 63b311c1b89..809116d89e3 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -24,7 +24,6 @@ -- with Accessibility; use Accessibility; -with Aspects;use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -6013,6 +6012,7 @@ package body Exp_Attr is begin if Nkind (E1) = N_Attribute_Reference then + Accum_Typ := Base_Type (Entity (Prefix (E1))); Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_Attribute_Reference (Loc, @@ -6023,12 +6023,15 @@ package body Exp_Attr is Comp))); elsif Ekind (Entity (E1)) = E_Procedure then + Accum_Typ := Etype (First_Formal (Entity (E1))); Stat := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Entity (E1), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Bnn, Loc), Comp)); + else + Accum_Typ := Etype (Entity (E1)); Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_Function_Call (Loc, @@ -6038,6 +6041,28 @@ package body Exp_Attr is Comp))); end if; + -- Try to cope if E1 is wrong because it is an overloaded + -- subprogram that happens to be the first candidate + -- on a homonym chain, but that resolution candidate turns + -- out to be the wrong one. + -- This workaround usually gets the right type, but it can + -- yield the wrong subtype of that type. + + if Base_Type (Accum_Typ) /= Base_Type (Etype (N)) then + Accum_Typ := Etype (N); + end if; + + -- Try to cope with wrong E1 when Etype (N) doesn't help + if Is_Universal_Numeric_Type (Accum_Typ) then + if Is_Array_Type (Etype (Prefix (N))) then + Accum_Typ := Component_Type (Etype (Prefix (N))); + else + -- Further hackery can be added here when there is a + -- demonstrated need. + null; + end if; + end if; + return Stat; end Build_Stat; @@ -6088,10 +6113,6 @@ package body Exp_Attr is End_Label => Empty, Statements => New_List (Build_Stat (Relocate_Node (Expr; - - -- Look at the context to find the type. - - Accum_Typ := Etype (N); end; else @@ -6121,40 +6142,6 @@ package body Exp_Attr is Statements => New_List ( Build_Stat (New_Occurrence_Of (Elem, Loc; - -- Look at the prefix to find the type. This is - -- modeled on Analyze_Iterator_Specification in Sem_Ch5. - - declare - Ptyp : constant Entity_Id := - Base_Type (Etype (Prefix (N))); - - begin - if Is_Array_Type (Ptyp) then -Accum_Typ := Component_Type (Ptyp); - - elsif Has_Aspect (Ptyp, Aspect_Iterable) then -declare - Element : constant Entity_Id := - Get_Iterable_Type_Primitive - (Ptyp, Name_Element); -begin - if Present (Element) then - Accum_Typ := Etype (Element); - end if; -end; - - else -declar
[COMMITTED] ada: Missing support for consistent assertion policy
From: Javier Miranda Add missing support for RM 10.2/5: the region for a pragma Assertion_Policy given as a configuration pragma is the declarative region for the entire compilation unit (or units) to which it applies. gcc/ada/ * sem_ch10.adb (Install_Inherited_Policy_Pragmas): New subprogram. (Remove_Inherited_Policy_Pragmas): New subprogram. (Analyze_Compilation_Unit): Call the new subprograms to install and remove inherited assertion policy pragmas. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch10.adb | 212 ++- 1 file changed, 208 insertions(+), 4 deletions(-) diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 7fc623b6278..73e5388affd 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -292,6 +292,18 @@ package body Sem_Ch10 is -- Spec_Context_Items to that of the spec. Parent packages are not -- examined for documentation purposes. + function Install_Inherited_Policy_Pragmas +(Comp_Unit : Node_Id) return Node_Id; + -- Install assertion_policy pragmas placed at the start of the spec of + -- the given compilation unit (and the spec of its parent units). Return + -- the last pragma found in the check policy list before installing + -- these pragmas; used to remove the installed pragmas. + + procedure Remove_Inherited_Policy_Pragmas (Last_Pragma : Node_Id); + -- Remove assertion_policy pragmas installed after the given pragma. If + -- Last_Pragma is empty then remove all the pragmas installed in the + -- check policy list (if any). + --- -- Check_Redundant_Withs -- --- @@ -631,6 +643,186 @@ package body Sem_Ch10 is end loop; end Check_Redundant_Withs; + -- + -- Install_Inherited_Policy_Pragmas -- + -- + + -- Opt.Check_Policy_List is handled as a stack; assertion policy + -- pragmas defined at inner scopes are placed at the beginning of + -- the list. Therefore, policy pragmas defined at the start of + -- parent units must be appended to the end of this list. + + -- When the compilation unit is a package body (or a subprogram body + -- that does not act as its spec) we recursively traverse to its spec + -- (and from there to its ultimate parent); when the compilation unit + -- is a child package (or subprogram) spec we recursively climb until + -- its ultimate parent. In both cases policy pragmas defined at the + -- beginning of all these traversed units are appended to the check + -- policy list in the way back to the current compilation unit (and + -- they are left installed in reverse order). For example: + -- + -- pragma Assertion_Policy (...) -- [policy-1] + -- package Pkg is ... + -- + -- pragma Assertion_Policy (...) -- [policy-2] + -- package Pkg.Child is ... + -- + -- pragma Assertion_Policy (...) -- [policy-3] + -- package body Pkg.Child is ... + -- + -- When the compilation unit Pkg.Child is analyzed, and its context + -- clauses are analyzed, these are the contents of Check_Policy_List: + -- + -- Opt.Check_Policy_List -> [policy-3] + -- ^ + -- last_policy_pragma + -- + -- After climbing to the ultimate parent spec, these are the contents + -- of Check_Policy_List: + -- + -- Opt.Check_Policy_List -> [policy-3] -> [policy-2] -> [policy-1] + -- ^ + -- last_policy_pragma + -- + -- The reference to the last policy pragma in the initial contents of + -- the list is used later to remove installed inherited pragmas. + + function Install_Inherited_Policy_Pragmas +(Comp_Unit : Node_Id) return Node_Id + is + Last_Policy_Pragma : Node_Id; + + procedure Install_Parent_Policy_Pragmas (N : Node_Id); + -- Recursively climb to the ultimate parent and install their policy + -- pragmas after Last_Policy_Pragma. + + --- + -- Install_Parent_Policy_Pragmas -- + --- + + procedure Install_Parent_Policy_Pragmas (N : Node_Id) is +Lib_Unit : constant Node_Id := Unit (N); +Item : Node_Id; + + begin +if Is_Child_Spec (Lib_Unit) then + Install_Parent_Policy_Pragmas (Parent_Spec (Lib_Unit)); + +elsif Nkind (Lib_Unit) = N_Package_Body then + Install_Parent_Policy_Pragmas (Library_Unit (N)); + +elsif Nkind (Lib_Unit) = N_Subprogram_Body +
[COMMITTED] ada: Fix small inaccuracy in previous change
From: Eric Botcazou The call to Build_Allocate_Deallocate_Proc must occur before the special accessibility check for class-wide allocation is generated, because this check comes with cleanup code. gcc/ada/ * exp_ch4.adb (Expand_Allocator_Expression): Move the first call to Build_Allocate_Deallocate_Proc up to before the accessibility check. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 8 +++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b1f7593de2a..762e75616a7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -960,12 +960,18 @@ package body Exp_Ch4 is end if; end if; + -- This needs to done before generating the accessibility check below + -- because the check comes with cleanup code that invokes Free on the + -- temporary and, therefore, expects the object to be attached to its + -- finalization collection if it is controlled. + + Build_Allocate_Deallocate_Proc (Declaration_Node (Temp), Mark => N); + -- Note: the accessibility check must be inserted after the call to -- [Deep_]Adjust to ensure proper completion of the assignment. Apply_Accessibility_Check_For_Allocator (N, Exp, Temp); - Build_Allocate_Deallocate_Proc (Declaration_Node (Temp), Mark => N); Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, PtrT); -- 2.43.2
[COMMITTED] ada: Fix ghost policy in use for generic instantiation
From: Yannick Moy The Ghost assertion policy relevant for analyzing a generic instantiation is the Ghost policy at the point of instantiation, not the one applicable for the generic itself. gcc/ada/ * ghost.adb (Mark_And_Set_Ghost_Instantiation): Fix the current Ghost policy for the instantiation. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/ghost.adb | 14 +- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 14951a031d9..677089039e8 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -1734,13 +1734,17 @@ package body Ghost is elsif Ghost_Mode = Ignore then Policy := Name_Ignore; - -- Inherit the "ghostness" of the generic unit + -- Inherit the "ghostness" of the generic unit, but the current Ghost + -- policy is the relevant one for the instantiation. - elsif Is_Checked_Ghost_Entity (Gen_Id) then - Policy := Name_Check; + elsif Is_Checked_Ghost_Entity (Gen_Id) +or else Is_Ignored_Ghost_Entity (Gen_Id) + then + Policy := Policy_In_Effect (Name_Ghost); - elsif Is_Ignored_Ghost_Entity (Gen_Id) then - Policy := Name_Ignore; + if Policy = No_Name then +Policy := Name_Ignore; + end if; end if; -- Mark the instantiation as Ghost -- 2.43.2
[COMMITTED] ada: Spurious unreferenced warning on selected component
From: Justin Squirek This patch fixes an error in the compiler whereby a selected component on the left hand side of an assignment statement may not get marked as referenced - leading to spurious unreferenced warnings on such objects. gcc/ada/ * sem_util.adb (Set_Referenced_Modified): Use Original_Node to avoid recursive calls on expanded / internal objects such that source nodes get appropriately marked as referenced. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 6 +- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b5c33638b35..4e1258e7cec 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -27625,7 +27625,11 @@ package body Sem_Util is -- Deal with indexed or selected component where prefix is modified if Nkind (N) in N_Indexed_Component | N_Selected_Component then - Pref := Prefix (N); + + -- Grab the original node to avoid looking at internally generated + -- objects. + + Pref := Original_Node (Prefix (N)); -- If prefix is access type, then it is the designated object that is -- being modified, which means we have no entity to set the flag on. -- 2.43.2
[COMMITTED] ada: Follow-up adjustment to earlier fix in Build_Allocate_Deallocate_Proc
From: Eric Botcazou The profile of the procedure built for an allocation on the secondary stack now includes the alignment parameter, so the parameter can just be forwarded in the call to Allocate_Any_Controlled. gcc/ada/ * exp_util.adb (Build_Allocate_Deallocate_Proc): Pass the alignment parameter in the inner call for a secondary stack allocation too. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_util.adb | 43 ++- 1 file changed, 18 insertions(+), 25 deletions(-) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 103d59e4deb..4b1c5322f62 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1081,10 +1081,8 @@ package body Exp_Util is -- allocations can be performed without getting the alignment from -- the type's Type Specific Record. - if ((Is_Allocate and then No (Alloc_Expr)) - or else - not Is_Class_Wide_Type (Desig_Typ)) - and then not Use_Secondary_Stack_Pool + if (Is_Allocate and then No (Alloc_Expr)) + or else not Is_Class_Wide_Type (Desig_Typ) then Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc)); @@ -1103,9 +1101,6 @@ package body Exp_Util is -- into the code that reads the value of alignment from the TSD -- (see Expand_N_Attribute_Reference) --- In the Use_Secondary_Stack_Pool case, Alig_Id is not --- passed in and therefore must not be referenced. - Append_To (Actuals, Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, @@ -1255,53 +1250,51 @@ package body Exp_Util is Proc_To_Call := RTE (RE_Deallocate_Any_Controlled); end if; - -- Create a custom Allocate / Deallocate routine which has identical - -- profile to that of System.Storage_Pools. + -- Create a custom Allocate/Deallocate routine which has identical + -- profile to that of System.Storage_Pools, except for a secondary + -- stack allocation where the profile must be identical to that of + -- the System.Secondary_Stack.SS_Allocate procedure (deallocation + -- is not supported for the secondary stack). declare --- P : Root_Storage_Pool function Pool_Param return Node_Id is ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Temporary (Loc, 'P'), Parameter_Type => New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc))); +-- P : Root_Storage_Pool --- A : [out] Address function Address_Param return Node_Id is ( Make_Parameter_Specification (Loc, Defining_Identifier => Addr_Id, Out_Present => Is_Allocate, Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc))); +-- A : [out] Address --- S : Storage_Count function Size_Param return Node_Id is ( Make_Parameter_Specification (Loc, Defining_Identifier => Size_Id, Parameter_Type => New_Occurrence_Of (RTE (RE_Storage_Count), Loc))); +-- S : Storage_Count --- L : Storage_Count function Alignment_Param return Node_Id is ( Make_Parameter_Specification (Loc, Defining_Identifier => Alig_Id, Parameter_Type => New_Occurrence_Of (RTE (RE_Storage_Count), Loc))); +-- L : Storage_Count -Formal_Params : List_Id; +Formal_Params : constant List_Id := + (if Use_Secondary_Stack_Pool +then New_List (Address_Param, Size_Param, Alignment_Param) +else + New_List +(Pool_Param, Address_Param, Size_Param, Alignment_Param)); +-- The list of formal parameters of the routine begin -if Use_Secondary_Stack_Pool then - -- Gigi expects a different profile in the Secondary_Stack_Pool - -- case. There must be no uses of the two missing formals - -- (i.e., Pool_Param and Alignment_Param) in this case. - Formal_Params := New_List - (Address_Param, Size_Param, Alignment_Param); -else - Formal_Params := New_List ( - Pool_Param, Address_Param, Size_Param, Alignment_Param); -end if; - Insert_Action (N, Make_Subprogram_Body (Loc, Specification => -- 2.43.2
[COMMITTED] ada: Correct System.Win32.LocalFileTimeToFileTime wrapper typo
From: Philippe Gil The parameters should be swapped to fit Fileapi.h documentation. BOOL LocalFileTimeToFileTime( [in] const FILETIME *lpLocalFileTime, [out] LPFILETIME lpFileTime ); gcc/ada/ * libgnat/s-win32.ads (LocalFileTimeToFileTime): Swap parameters. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-win32.ads | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gcc/ada/libgnat/s-win32.ads b/gcc/ada/libgnat/s-win32.ads index 6ea66153639..6e8e246d903 100644 --- a/gcc/ada/libgnat/s-win32.ads +++ b/gcc/ada/libgnat/s-win32.ads @@ -315,8 +315,8 @@ package System.Win32 is pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime"); function LocalFileTimeToFileTime - (lpFileTime : access Long_Long_Integer; - lpLocalFileTime : access Long_Long_Integer) return BOOL; + (lpLocalFileTime : access Long_Long_Integer; + lpFileTime : access Long_Long_Integer) return BOOL; pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime"); procedure Sleep (dwMilliseconds : DWORD); -- 2.43.2
[COMMITTED] ada: Update of SPARK RM legality rules on ghost code
From: Yannick Moy
Update checking of ghost code after a small change in SPARK RM
rules 6.9(15) and 6.9(20), so that the Ghost assertion policy
that matters when checking the validity of a reference to a ghost entity
in an assertion expression is the Ghost assertion policy at the point
of declaration of the entity.
Also fix references to SPARK RM rules in comments, which were off by two
in many cases after the insertion of rules 13 and 14 regarding generic
instantiations.
gcc/ada/
* contracts.adb: Fix references to SPARK RM rules.
* freeze.adb: Same.
* ghost.adb: Fix references to SPARK RM rules.
(Check_Ghost_Context): Update checking of references to
ghost entities in assertion expressions.
* sem_ch6.adb: Fix references to SPARK RM rules.
* sem_prag.adb: Same.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/contracts.adb | 2 +-
gcc/ada/freeze.adb| 2 +-
gcc/ada/ghost.adb | 44 +++
gcc/ada/sem_ch6.adb | 14 +++---
gcc/ada/sem_prag.adb | 12 ++--
5 files changed, 39 insertions(+), 35 deletions(-)
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 810b360fb94..9fc9e05db68 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -1114,7 +1114,7 @@ package body Contracts is
if Comes_From_Source (Obj_Id) and then Is_Ghost_Entity (Obj_Id) then
-- A Ghost object cannot be of a type that yields a synchronized
- -- object (SPARK RM 6.9(19)).
+ -- object (SPARK RM 6.9(21)).
if Yields_Synchronized_Object (Obj_Typ) then
Error_Msg_N ("ghost object & cannot be synchronized", Obj_Id);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index dd4eff1ed19..a980c7e5b47 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -4094,7 +4094,7 @@ package body Freeze is
<>
-- A Ghost type cannot have a component of protected or task type
- -- (SPARK RM 6.9(19)).
+ -- (SPARK RM 6.9(21)).
if Is_Ghost_Entity (Arr) and then Is_Concurrent_Type (Ctyp) then
Error_Msg_N
diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
index 677089039e8..d220e0e1ec0 100644
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -121,7 +121,7 @@ package body Ghost is
null;
-- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
+ -- point of completion must match (SPARK RM 6.9(16)).
elsif Is_Checked_Ghost_Entity (Prev_Id)
and then Policy = Name_Ignore
@@ -173,9 +173,9 @@ package body Ghost is
--
--* Be subject to pragma Ghost
- function Is_OK_Pragma (Prag : Node_Id) return Boolean;
+ function Is_OK_Pragma (Prag : Node_Id; Id : Entity_Id) return Boolean;
-- Determine whether node Prag is a suitable context for a reference
- -- to a Ghost entity. To qualify as such, Prag must either
+ -- to a Ghost entity Id. To qualify as such, Prag must either
--
--* Be an assertion expression pragma
--
@@ -318,9 +318,11 @@ package body Ghost is
-- Is_OK_Pragma --
--
- function Is_OK_Pragma (Prag : Node_Id) return Boolean is
+ function Is_OK_Pragma (Prag : Node_Id; Id : Entity_Id) return Boolean
+ is
procedure Check_Policies (Prag_Nam : Name_Id);
--- Verify that the Ghost policy in effect is the same as the
+-- Verify that the Ghost policy in effect at the point of the
+-- declaration of Ghost entity Id (if present) is the same as the
-- assertion policy for pragma name Prag_Nam. Emit an error if
-- this is not the case.
@@ -330,14 +332,16 @@ package body Ghost is
procedure Check_Policies (Prag_Nam : Name_Id) is
AP : constant Name_Id := Check_Kind (Prag_Nam);
- GP : constant Name_Id := Policy_In_Effect (Name_Ghost);
begin
- -- If the Ghost policy in effect at the point of a Ghost entity
- -- reference is Ignore, then the assertion policy of the pragma
- -- must be Ignore (SPARK RM 6.9(18)).
+ -- If the Ghost policy in effect at the point of the
+ -- declaration of Ghost entity Id is Ignore, then the assertion
+ -- policy of the pragma must be Ignore (SPARK RM 6.9(20)).
- if GP = Name_Ignore and then AP /= Name_Ignore then
+ if Present (Id)
+ and then not Is_Checked_Ghost_Entity (Id)
+ and then AP /= Name_Ignore
+ then
Error_Msg_N
("incompatible ghost policies in effect",
Ghost_Ref);
@@ -388,7 +392,7 @@ package body Ghost is
[COMMITTED] ada: Factor out implementation of default initialization for objects
From: Eric Botcazou As written down in a comment, "There is a *huge* amount of code duplication" in the implementation of default initializaion for objects in the front-end, between the (static) declaration case and the dynamic allocation case. This change factors out the implementation of the (static) declaration case and uses it for the dynamic allocation case, with the following benefits: 1. getting rid of the duplication and reducing total line count, 2. bringing optimizations implemented for the (static) declaration case to the dynamic allocation case, 3. performing the missing abort deferral prescribed by RM 9.8(9) in the dynamic allocation case. gcc/ada/ * exp_aggr.adb (Build_Record_Aggr_Code): Replace reference to Build_Task_Allocate_Block_With_Init_Stmts in comment with reference to Build_Task_Allocate_Block. (Convert_Aggr_In_Allocator): Likewise for the call in the code. * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Likewise. * exp_ch3.ads: Alphabetize clauses. (Build_Default_Initialization): New function declaration. (Build_Default_Simple_Initialization): Likewise. (Build_Initialization_Call): Add Target_Ref parameter with default. * exp_ch3.adb (Build_Default_Initialization): New function extracted from... (Build_Default_Simple_Initialization): Likewise. (Build_Initialization_Call): Add Target_Ref parameter with default. (Expand_N_Object_Declaration): ...here. (Default_Initialize_Object): Call Build_Default_Initialization and Build_Default_Simple_Initialization. * exp_ch4.adb (Expand_Allocator_Expression): Minor comment tweaks. (Expand_N_Allocator): Call Build_Default_Initialization and Build_Default_Simple_Initialization to implement the default initialization of the allocated object. * exp_ch9.ads (Build_Task_Allocate_Block): Delete. (Build_Task_Allocate_Block_With_Init_Stmts): Rename into... (Build_Task_Allocate_Block): ...this. * exp_ch9.adb: Remove clauses for Exp_Tss. (Build_Task_Allocate_Block): Delete. (Build_Task_Allocate_Block_With_Init_Stmts): Rename into... (Build_Task_Allocate_Block): ...this. * exp_util.adb (Build_Allocate_Deallocate_Proc): Remove unnecessary initialization expression, adjust commentary and replace early exit with assertion. * sem_ch4.adb (Analyze_Allocator): In the null-exclusion case, call Apply_Compile_Time_Constraint_Error to insert the raise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb |4 +- gcc/ada/exp_ch3.adb | 1015 +++--- gcc/ada/exp_ch3.ads | 53 ++- gcc/ada/exp_ch4.adb | 605 +++-- gcc/ada/exp_ch6.adb |2 +- gcc/ada/exp_ch9.adb | 67 +-- gcc/ada/exp_ch9.ads | 19 +- gcc/ada/exp_util.adb | 28 +- gcc/ada/sem_ch4.adb | 21 +- 9 files changed, 795 insertions(+), 1019 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c82bd07aedc..86f304e90bb 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -3192,7 +3192,7 @@ package body Exp_Aggr is -- Ada 2005 (AI-287): If the component type has tasks then -- generate the activation chain and master entities (except -- in case of an allocator because in that case these entities --- are generated by Build_Task_Allocate_Block_With_Init_Stmts). +-- are generated by Build_Task_Allocate_Block). declare Ctype: constant Entity_Id := Etype (Selector); @@ -3567,7 +3567,7 @@ package body Exp_Aggr is Init_Stmts := Late_Expansion (Aggr, Typ, Occ); if Has_Task (Typ) then - Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts); + Build_Task_Allocate_Block (L, Aggr, Init_Stmts); Insert_Actions (Alloc, L); else Insert_Actions (Alloc, Init_Stmts); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8e5c1f08a86..4bb69b03e3d 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -962,6 +962,524 @@ package body Exp_Ch3 is end if; end Build_Array_Init_Proc; + -- + -- Build_Default_Initialization -- + -- + + function Build_Default_Initialization + (N : Node_Id; + Typ: Entity_Id; + Obj_Id : Entity_Id; + For_CW : Boolean := False; + Target_Ref : Node_Id := Empty) return List_Id + is + Exceptions_OK : constant Boolean := +not Restriction_Active (No_Exception_Propagation); + Loc : constant Source_Ptr := Sloc (N); + + function New_Object_Reference return Node_Id; + -- Return either a ref
[COMMITTED] ada: Fix double finalization for dependent expression of case expression
From: Eric Botcazou The recent fix to Default_Initialize_Object, which has ensured that the No_Initialization flag set on an object declaration, for example for the temporary created by Expand_N_Case_Expression, is honored in all cases, has also uncovered a latent issue in the machinery responsible for the finalization of transient objects. More specifically, the answer returned by the Is_Finalizable_Transient predicate for an object of an access type is different when it is left uninitialized (true) than when it is initialized to null (false), which is incorrect; it must return false in both cases, because the only case where an object can be finalized by the machinery through an access value is when this value is a reference (N_Reference node) to the object. This was already more or less the current state of the evolution of the predicate, but this now explicitly states it in the code. The change also sets the No_Initialization flag for the temporary created by Expand_N_If_Expression for the sake of consistency. gcc/ada/ * exp_ch4.adb (Expand_N_If_Expression): Set No_Initialization on the declaration of the temporary in the by-reference case. * exp_util.adb (Initialized_By_Access): Delete. (Is_Allocated): Likewise. (Initialized_By_Reference): New predicate. (Is_Finalizable_Transient): If the transient object is of an access type, do not return true unless it is initialized by a reference. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 1 + gcc/ada/exp_util.adb | 66 ++-- 2 files changed, 22 insertions(+), 45 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index fcbc82f5610..d8895d648d4 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5549,6 +5549,7 @@ package body Exp_Ch4 is Make_Object_Declaration (Loc, Defining_Identifier => Cnn, Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); +Set_No_Initialization (Decl); -- Generate: --if Cond then diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e411f32a519..103d59e4deb 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8234,11 +8234,6 @@ package body Exp_Util is Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); - function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean; - -- Determine whether transient object Trans_Id is initialized either - -- by a function call which returns an access type or simply renames - -- another pointer. - function Initialized_By_Aliased_BIP_Func_Call (Trans_Id : Entity_Id) return Boolean; -- Determine whether transient object Trans_Id is initialized by a @@ -8247,6 +8242,11 @@ package body Exp_Util is -- This case creates an aliasing between the returned value and the -- value denoted by BIPaccess. + function Initialized_By_Reference (Trans_Id : Entity_Id) return Boolean; + -- Determine whether transient object Trans_Id is initialized by a + -- reference to another object. This is the only case where we can + -- possibly finalize a transient object through an access value. + function Is_Aliased (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean; @@ -8254,9 +8254,6 @@ package body Exp_Util is -- aliased through 'reference in the statement list starting from -- First_Stmt. - 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; @@ -8275,20 +8272,6 @@ package body Exp_Util is -- Return True if N is directly part of a build-in-place return -- statement. - --- - -- Initialized_By_Access -- - --- - - function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is - Expr : constant Node_Id := Expression (Parent (Trans_Id)); - - begin - return - Present (Expr) - and then Nkind (Expr) /= N_Reference - and then Is_Access_Type (Etype (Expr)); - end Initialized_By_Access; - -- -- Initialized_By_Aliased_BIP_Func_Call -- -- @@ -8386,6 +8369,18 @@ package body Exp_Util is return False; end Initialized_By_Aliased_BIP_Func_Call; + -- + -- Initialized_By_Reference -- + -- + + function Initialized_By_Reference (Trans_Id : Entity_Id) return Boolean + is +
[COMMITTED] ada: Small fix to Default_Initialize_Object
From: Eric Botcazou Unlike what is assumed in other parts of the front-end, some objects created with No_Initialization set on their declaration may end up being initialized with a default value. gcc/ada/ * exp_ch3.adb (Default_Initialize_Object): Return immediately when either Has_Init_Expression or No_Initialization is set on the node. Tidy up the rest of the code accordingly. (Simple_Initialization_OK): Do not test Has_Init_Expression here. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 26 ++ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 2477a221c96..8e5c1f08a86 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6768,6 +6768,9 @@ package body Exp_Ch3 is --- procedure Default_Initialize_Object (After : Node_Id) is + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + function New_Object_Reference return Node_Id; -- Return a new reference to Def_Id with attributes Assignment_OK and -- Must_Not_Freeze already set. @@ -6806,13 +6809,10 @@ package body Exp_Ch3 is (Init_Typ : Entity_Id) return Boolean is begin --- Do not consider the object declaration if it comes with an --- initialization expression, or is internal in which case it --- will be assigned later. +-- Skip internal entities as specified in Einfo return not Is_Internal (Def_Id) -and then not Has_Init_Expression (N) and then Needs_Simple_Initialization (Typ => Init_Typ, Consider_IS => @@ -6822,9 +6822,6 @@ package body Exp_Ch3 is -- Local variables - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - Aggr_Init : Node_Id; Comp_Init : List_Id := No_List; Fin_Block : Node_Id; @@ -6836,6 +6833,12 @@ package body Exp_Ch3 is -- Start of processing for Default_Initialize_Object begin + -- Nothing to do if the object has an initialization expression or + -- need not be initialized. + + if Has_Init_Expression (N) or else No_Initialization (N) then +return; + -- Default initialization is suppressed for objects that are already -- known to be imported (i.e. whose declaration specifies the Import -- aspect). Note that for objects with a pragma Import, we generate @@ -6843,7 +6846,9 @@ package body Exp_Ch3 is -- the pragma. It is also suppressed for variables for which a pragma -- Suppress_Initialization has been explicitly given - if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then + elsif Is_Imported (Def_Id) + or else Suppress_Initialization (Def_Id) + then return; -- Nothing to do if the object being initialized is of a task type @@ -6877,7 +6882,6 @@ package body Exp_Ch3 is -- Initialize the components of the object if Has_Non_Null_Base_Init_Proc (Typ) - and then not No_Initialization (N) and then not Initialization_Suppressed (Typ) then -- Do not initialize the components if No_Default_Initialization @@ -6950,7 +6954,6 @@ package body Exp_Ch3 is and then Simple_Initialization_OK (Component_Type (Typ)) then - Set_No_Initialization (N, False); Set_Expression (N, Get_Simple_Init_Val (Typ => Typ, @@ -6978,7 +6981,6 @@ package body Exp_Ch3 is -- Provide a default value if the object needs simple initialization elsif Simple_Initialization_OK (Typ) then -Set_No_Initialization (N, False); Set_Expression (N, Get_Simple_Init_Val (Typ => Typ, @@ -6992,7 +6994,7 @@ package body Exp_Ch3 is -- Initialize the object, generate: --[Deep_]Initialize (Obj); - if Needs_Finalization (Typ) and then not No_Initialization (N) then + if Needs_Finalization (Typ) then Obj_Init := Make_Init_Call (Obj_Ref => New_Object_Reference, -- 2.43.2
[COMMITTED] ada: Fix crash with -gnatyB and -gnatdJ
From: Ronan Desplanques
The crash this patch fixes happened because calling the Errout.Error_Msg
procedures that don't have an N parameter is not allowed when not
parsing and -gnatdJ is on. And -gnatyB style checks are not emitted during
parsing but during semantic analysis.
This commit moves Check_Boolean_Operator from Styleg to Style so it can
call Errout.Error_Msg with a Node_Id parameter. This change of package
makes sense because:
1. The compiler is currently the only user of Check_Boolean_Operator.
2. Other tools don't do semantic analysis, and so cannot possibly
know when to use Check_Boolean_Operator anyway.
gcc/ada/
* styleg.ads (Check_Boolean_Operator): Moved ...
* style.ads (Check_Boolean_Operator): ... here.
* styleg.adb (Check_Boolean_Operator): Moved ...
* style.adb (Check_Boolean_Operator): ... here. Also add node
parameter to call to Errout.Error_Msg.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/style.adb | 81
gcc/ada/style.ads | 3 +-
gcc/ada/styleg.adb | 83 --
gcc/ada/styleg.ads | 4 ---
4 files changed, 82 insertions(+), 89 deletions(-)
diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb
index e73bfddb524..aaa668aab00 100644
--- a/gcc/ada/style.adb
+++ b/gcc/ada/style.adb
@@ -94,6 +94,87 @@ package body Style is
end if;
end Check_Array_Attribute_Index;
+
+ -- Check_Boolean_Operator --
+
+
+ procedure Check_Boolean_Operator (Node : Node_Id) is
+
+ function OK_Boolean_Operand (N : Node_Id) return Boolean;
+ -- Returns True for simple variable, or "not X1" or "X1 and X2" or
+ -- "X1 or X2" where X1, X2 are recursively OK_Boolean_Operand's.
+
+
+ -- OK_Boolean_Operand --
+
+
+ function OK_Boolean_Operand (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) in N_Identifier | N_Expanded_Name then
+return True;
+
+ elsif Nkind (N) = N_Op_Not then
+return OK_Boolean_Operand (Original_Node (Right_Opnd (N)));
+
+ elsif Nkind (N) in N_Op_And | N_Op_Or then
+return OK_Boolean_Operand (Original_Node (Left_Opnd (N)))
+ and then
+ OK_Boolean_Operand (Original_Node (Right_Opnd (N)));
+
+ else
+return False;
+ end if;
+ end OK_Boolean_Operand;
+
+ -- Start of processing for Check_Boolean_Operator
+
+ begin
+ if Style_Check_Boolean_And_Or
+and then Comes_From_Source (Node)
+ then
+ declare
+Orig : constant Node_Id := Original_Node (Node);
+
+ begin
+if Nkind (Orig) in N_Op_And | N_Op_Or then
+ declare
+ L : constant Node_Id := Original_Node (Left_Opnd (Orig));
+ R : constant Node_Id := Original_Node (Right_Opnd (Orig));
+
+ begin
+ -- First OK case, simple boolean constants/identifiers
+
+ if OK_Boolean_Operand (L)
+ and then
+ OK_Boolean_Operand (R)
+ then
+ return;
+
+ -- Second OK case, modular types
+
+ elsif Is_Modular_Integer_Type (Etype (Node)) then
+ return;
+
+ -- Third OK case, array types
+
+ elsif Is_Array_Type (Etype (Node)) then
+ return;
+
+ -- Otherwise we have an error
+
+ elsif Nkind (Orig) = N_Op_And then
+ Error_Msg -- CODEFIX
+ ("(style) `AND THEN` required?B?", Sloc (Orig), Orig);
+ else
+ Error_Msg -- CODEFIX
+ ("(style) `OR ELSE` required?B?", Sloc (Orig), Orig);
+ end if;
+ end;
+end if;
+ end;
+ end if;
+ end Check_Boolean_Operator;
+
--
-- Check_Identifier --
--
diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads
index dc8b337f2bd..c0925e9ce34 100644
--- a/gcc/ada/style.ads
+++ b/gcc/ada/style.ads
@@ -90,8 +90,7 @@ package Style is
-- designator is a reserved word (access, digits, delta or range) to allow
-- differing rules for the two cases.
- procedure Check_Boolean_Operator (Node : Node_Id)
- renames Style_Inst.Check_Boolean_Operator;
+ procedure Check_Boolean_Operator (Node : Node_Id);
-- Called after resolving AND or OR node to check short circuit rules
procedure Check_Box
diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb
index 5c439c9a0b2..287589f92da 100644
--- a/gcc/ada/styleg.adb
+++ b/gcc/ada/styleg.adb
@@ -30,8 +30,6 @@
with Atree; use Atree;
with Casing; use Casing;
with C
[COMMITTED] ada: Small fix to printing of raise statements
From: Eric Botcazou
The Name is optional on these nodes and a superflous space is printed if
it is not present on them.
gcc/ada/
* sprint.adb (Sprint_Node_Actual) : Be prepared
for an empty Name.
: Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sprint.adb | 16
1 file changed, 12 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 938b378b66b..3f73006ad6e 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -3116,8 +3116,12 @@ package body Sprint is
Write_Condition_And_Reason (Node);
when N_Raise_Statement =>
-Write_Indent_Str_Sloc ("raise ");
-Sprint_Node (Name (Node));
+if Present (Name (Node)) then
+ Write_Indent_Str_Sloc ("raise ");
+ Sprint_Node (Name (Node));
+else
+ Write_Indent_Str_Sloc ("raise");
+end if;
if Present (Expression (Node)) then
Write_Str_With_Col_Check_Sloc (" with ");
@@ -3127,8 +3131,12 @@ package body Sprint is
Write_Char (';');
when N_Raise_When_Statement =>
-Write_Indent_Str_Sloc ("raise ");
-Sprint_Node (Name (Node));
+if Present (Name (Node)) then
+ Write_Indent_Str_Sloc ("raise ");
+ Sprint_Node (Name (Node));
+else
+ Write_Indent_Str_Sloc ("raise");
+end if;
Write_Str (" when ");
Sprint_Node (Condition (Node));
--
2.43.2
[COMMITTED] ada: Attributes Put_Image and Object_Size are defined by Ada 2022
From: Piotr Trojanek
Recognize references to attributes Put_Image and Object_Size as
language-defined in Ada 2022 and implementation-defined in earlier
versions of Ada. Other attributes listed in Ada 2022 RM, K.2 and
currently implemented in GNAT are correctly categorized.
This change only affects code with restriction
No_Implementation_Attributes.
gcc/ada/
* sem_attr.adb (Attribute_22): Add Put_Image and Object_Size.
* sem_attr.ads (Attribute_Imp_Def): Remove Object_Size.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 4 +++-
gcc/ada/sem_attr.ads | 11 ---
2 files changed, 3 insertions(+), 12 deletions(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 65442d45a85..b979ffdf0b1 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -181,7 +181,9 @@ package body Sem_Attr is
(Attribute_Enum_Rep |
Attribute_Enum_Val |
Attribute_Index|
- Attribute_Preelaborable_Initialization => True,
+ Attribute_Object_Size |
+ Attribute_Preelaborable_Initialization |
+ Attribute_Put_Image=> True,
others => False);
-- The following array contains all attributes that imply a modification
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 4c9f27043c6..65b7b534711 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -373,17 +373,6 @@ package Sem_Attr is
-- other composite object passed by reference, there is no other way
-- of specifying that a zero address should be passed.
- -
- -- Object_Size --
- -
-
- Attribute_Object_Size => True,
- -- Type'Object_Size is the same as Type'Size for all types except
- -- fixed-point types and discrete types. For fixed-point types and
- -- discrete types, this attribute gives the size used for default
- -- allocation of objects and components of the size. See section in
- -- Einfo ("Handling of Type'Size values") for further details.
-
-
-- Passed_By_Reference --
-
--
2.43.2
[COMMITTED] ada: Fix crash on Compile_Time_Warning in dead code
From: Bob Duff If a pragma Compile_Time_Warning triggers, and the pragma is later removed because it is dead code, then the compiler can return a bad exit code. This causes gprbuild to report "*** compilation phase failed". This is because Total_Errors_Detected, which is declared as Nat, goes negative, causing Constraint_Error. In assertions-off mode, the Constraint_Error is not detected, but the compiler nonetheless reports a bad exit code. This patch prevents that negative count. gcc/ada/ * errout.adb (Output_Messages): Protect against the total going negative. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/errout.adb | 11 --- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index d28a410f47b..c4761bd1bc9 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -3399,11 +3399,16 @@ package body Errout is if Warning_Mode = Treat_As_Error then declare -Compile_Time_Pragma_Warnings : constant Int := +Compile_Time_Pragma_Warnings : constant Nat := Count_Compile_Time_Pragma_Warnings; - begin -Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected +Total : constant Int := Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages - Compile_Time_Pragma_Warnings; +-- We need to protect against a negative Total here, because +-- if a pragma Compile_Time_Warning occurs in dead code, it +-- gets counted in Compile_Time_Pragma_Warnings but not in +-- Warnings_Detected. + begin +Total_Errors_Detected := Int'Max (Total, 0); Warnings_Detected := Warning_Info_Messages + Compile_Time_Pragma_Warnings; end; -- 2.43.2
[COMMITTED] ada: Refine type of a local variable
From: Piotr Trojanek Code cleanup; semantics is unaffected. gcc/ada/ * sem_util.adb (Has_No_Output): Iteration with First_Formal/Next_Formal involves Entity_Ids. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e9ab6650dac..03055039a1f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4203,7 +4203,7 @@ package body Sem_Util is --- function Has_No_Output (Subp : Entity_Id) return Boolean is - Param : Node_Id; + Param : Entity_Id; begin -- A function has its result as output -- 2.43.2
[COMMITTED] ada: Remove code that expected pre/post being split into conjuncts
From: Piotr Trojanek The removed code is no longer needed (and causes assertion failures). Most likely it should have been using the Split_PPC flag. gcc/ada/ * sem_util.adb (Is_Potentially_Unevaluated): Remove code for recovering the original structure of expressions with AND THEN. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 29 ++--- 1 file changed, 2 insertions(+), 27 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1166c68b972..b5c33638b35 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -19582,39 +19582,14 @@ package body Sem_Util is -- Local variables - Par : Node_Id; Expr : Node_Id; + Par : Node_Id; -- Start of processing for Is_Potentially_Unevaluated begin Expr := N; - Par := N; - - -- A postcondition whose expression is a short-circuit is broken down - -- into individual aspects for better exception reporting. The original - -- short-circuit expression is rewritten as the second operand, and an - -- occurrence of 'Old in that operand is potentially unevaluated. - -- See sem_ch13.adb for details of this transformation. The reference - -- to 'Old may appear within an expression, so we must look for the - -- enclosing pragma argument in the tree that contains the reference. - - while Present (Par) -and then Nkind (Par) /= N_Pragma_Argument_Association - loop - if Is_Rewrite_Substitution (Par) - and then Nkind (Original_Node (Par)) = N_And_Then - then -return True; - end if; - - Par := Parent (Par); - end loop; - - -- Other cases; 'Old appears within other expression (not the top-level - -- conjunct in a postcondition) with a potentially unevaluated operand. - - Par := Parent (Expr); + Par := Parent (Expr); while Present (Par) and then Nkind (Par) /= N_Pragma_Argument_Association -- 2.43.2
[COMMITTED] ada: Revert recent change for Put_Image and Object_Size attributes
From: Piotr Trojanek
Recent change for attribute Object_Size caused spurious errors when
restriction No_Implementation_Attributes is active and attribute
Object_Size is introduced by expansion of dispatching operations.
Temporarily revert that change for a further investigation.
gcc/ada/
* sem_attr.adb (Attribute_22): Remove Put_Image and Object_Size.
* sem_attr.ads (Attribute_Imp_Def): Restore Object_Size.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 4 +---
gcc/ada/sem_attr.ads | 11 +++
2 files changed, 12 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index b979ffdf0b1..65442d45a85 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -181,9 +181,7 @@ package body Sem_Attr is
(Attribute_Enum_Rep |
Attribute_Enum_Val |
Attribute_Index|
- Attribute_Object_Size |
- Attribute_Preelaborable_Initialization |
- Attribute_Put_Image=> True,
+ Attribute_Preelaborable_Initialization => True,
others => False);
-- The following array contains all attributes that imply a modification
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 65b7b534711..4c9f27043c6 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -373,6 +373,17 @@ package Sem_Attr is
-- other composite object passed by reference, there is no other way
-- of specifying that a zero address should be passed.
+ -
+ -- Object_Size --
+ -
+
+ Attribute_Object_Size => True,
+ -- Type'Object_Size is the same as Type'Size for all types except
+ -- fixed-point types and discrete types. For fixed-point types and
+ -- discrete types, this attribute gives the size used for default
+ -- allocation of objects and components of the size. See section in
+ -- Einfo ("Handling of Type'Size values") for further details.
+
-
-- Passed_By_Reference --
-
--
2.43.2
[COMMITTED] ada: Refactor repeated code for querying Boolean-valued aspects
From: Piotr Trojanek Code cleanup following a fix for aspect Exclusive_Functions; semantics is unaffected. gcc/ada/ * exp_ch9.adb (Build_Protected_Subprogram_Body, Build_Protected_Subprogram_Call_Cleanup): Reuse refactored routine. * sem_util.adb (Has_Enabled_Aspect): Refactored repeated code. (Is_Static_Function): Reuse refactored routine. * sem_util.ads (Has_Enabled_Aspect): New query routine refactored from repeated code. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch9.adb | 19 +++ gcc/ada/sem_util.adb | 28 +++- gcc/ada/sem_util.ads | 6 ++ 3 files changed, 32 insertions(+), 21 deletions(-) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 1b231b8bf2c..a89e3247647 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -3835,13 +3835,7 @@ package body Exp_Ch9 is Expression => New_Occurrence_Of (R, Loc)); end if; - if Has_Aspect (Pid, Aspect_Exclusive_Functions) - and then - (No (Find_Value_Of_Aspect (Pid, Aspect_Exclusive_Functions)) - or else - Is_True (Static_Boolean (Find_Value_Of_Aspect - (Pid, Aspect_Exclusive_Functions - then + if Has_Enabled_Aspect (Pid, Aspect_Exclusive_Functions) then Lock_Kind := RE_Lock; else Lock_Kind := RE_Lock_Read_Only; @@ -4041,16 +4035,9 @@ package body Exp_Ch9 is if (Nkind (Op_Spec) = N_Procedure_Specification or else (Nkind (Op_Spec) = N_Function_Specification - and then Has_Aspect (Conc_Typ, Aspect_Exclusive_Functions) and then - (No - (Find_Value_Of_Aspect (Conc_Typ, -Aspect_Exclusive_Functions)) - or else -Is_True - (Static_Boolean - (Find_Value_Of_Aspect -(Conc_Typ, Aspect_Exclusive_Functions)) + Has_Enabled_Aspect + (Conc_Typ, Aspect_Exclusive_Functions))) and then Has_Entries (Conc_Typ) then case Corresponding_Runtime_Package (Conc_Typ) is diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b30cbcd57e9..e9ab6650dac 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13484,6 +13484,28 @@ package body Sem_Util is return False; end Has_Effectively_Volatile_Component; + + -- Has_Enabled_Aspect -- + + + function Has_Enabled_Aspect + (Id : Entity_Id; + A : Aspect_Id) + return Boolean + is + Asp : constant Node_Id := Find_Aspect (Id, A); + begin + if Present (Asp) then + if Present (Expression (Asp)) then +return Is_True (Static_Boolean (Expression (Asp))); + else +return True; + end if; + else + return False; + end if; + end Has_Enabled_Aspect; + -- Has_Volatile_Component -- @@ -20356,11 +20378,7 @@ package body Sem_Util is -- for efficiency. return Ada_Version >= Ada_2022 -and then Has_Aspect (Subp, Aspect_Static) -and then - (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) -or else Is_True (Static_Boolean - (Find_Value_Of_Aspect (Subp, Aspect_Static; +and then Has_Enabled_Aspect (Subp, Aspect_Static); end Is_Static_Function; - diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a5eb1ecd7c1..527b1075c3f 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1559,6 +1559,12 @@ package Sem_Util is -- Given arbitrary type Typ, determine whether it contains at least one -- effectively volatile component. + function Has_Enabled_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean + with Pre => A in Boolean_Aspects; + -- Returns True if a Boolean-valued aspect is enabled on entity Id; i.e. it + -- is present and either has no aspect definition or its aspect definition + -- statically evaluates to True. + function Has_Volatile_Component (Typ : Entity_Id) return Boolean; -- Given arbitrary type Typ, determine whether it contains at least one -- volatile component. -- 2.43.2
[COMMITTED] ada: Remove dynamic frame in System.Image_D and document it in System.Image_F
From: Eric Botcazou The former can easily be removed while the latter cannot. gcc/ada/ * libgnat/s-imaged.ads (System.Image_D): Add Uns formal parameter. * libgnat/s-imaged.adb: Add with clauses for System.Image_I, System.Value_I_Spec and System.Value_U_Spec. (Uns_Spec): New instance of System.Value_U_Spec. (Int_Spec): New instance of System.Value_I_Spec. (Image_I): New instance of System.Image_I. (Set_Image_Integer): New renaming. (Set_Image_Decimal): Replace 'Image with call to Set_Image_Integer. * libgnat/s-imde32.ads (Uns32): New subtype. (Impl): Pass Uns32 as second actual paramter to Image_D. * libgnat/s-imde64.ads (Uns64): New subtype. (Impl): Pass Uns64 as second actual paramter to Image_D. * libgnat/s-imde128.ads (Uns128): New subtype. (Impl): Pass Uns128 as second actual paramter to Image_D. * libgnat/s-imagef.adb (Set_Image_Fixed): Document bounds for the A, D and AF local constants. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-imaged.adb | 55 +-- gcc/ada/libgnat/s-imaged.ads | 5 ++-- gcc/ada/libgnat/s-imagef.adb | 9 ++ gcc/ada/libgnat/s-imde128.ads | 3 +- gcc/ada/libgnat/s-imde32.ads | 3 +- gcc/ada/libgnat/s-imde64.ads | 3 +- 6 files changed, 70 insertions(+), 8 deletions(-) diff --git a/gcc/ada/libgnat/s-imaged.adb b/gcc/ada/libgnat/s-imaged.adb index 800a8e421cd..3a3b34960ca 100644 --- a/gcc/ada/libgnat/s-imaged.adb +++ b/gcc/ada/libgnat/s-imaged.adb @@ -29,10 +29,42 @@ -- -- -- +with System.Image_I; with System.Img_Util; use System.Img_Util; +with System.Value_I_Spec; +with System.Value_U_Spec; package body System.Image_D is + -- Contracts, ghost code, loop invariants and assertions in this unit are + -- meant for analysis only, not for run-time checking, as it would be too + -- costly otherwise. This is enforced by setting the assertion policy to + -- Ignore. + + pragma Assertion_Policy (Assert => Ignore, +Assert_And_Cut => Ignore, +Contract_Cases => Ignore, +Ghost => Ignore, +Loop_Invariant => Ignore, +Pre=> Ignore, +Post => Ignore, +Subprogram_Variant => Ignore); + + package Uns_Spec is new System.Value_U_Spec (Uns); + package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec); + + package Image_I is new System.Image_I + (Int=> Int, + Uns=> Uns, + U_Spec => Uns_Spec, + I_Spec => Int_Spec); + + procedure Set_Image_Integer + (V : Int; + S : in out String; + P : in out Natural) + renames Image_I.Set_Image_Integer; + --- -- Image_Decimal -- --- @@ -71,11 +103,28 @@ package body System.Image_D is Aft : Natural; Exp : Natural) is - Digs : String := Int'Image (V); - -- Sign and digits of decimal value + Maxdigs : constant Natural := Int'Width; + -- Maximum length needed for Image of an Int + + Digs : String (1 .. Maxdigs); + Ndigs : Natural; + -- Buffer for the image of the integer value begin - Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); + -- Set the first character like Image + + if V >= 0 then + Digs (1) := ' '; + Ndigs := 1; + else + Ndigs := 0; + end if; + + Set_Image_Integer (V, Digs, Ndigs); + + pragma Assert (1 <= Ndigs and then Ndigs <= Maxdigs); + + Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp); end Set_Image_Decimal; end System.Image_D; diff --git a/gcc/ada/libgnat/s-imaged.ads b/gcc/ada/libgnat/s-imaged.ads index 5fe8f82fa17..927ea50e769 100644 --- a/gcc/ada/libgnat/s-imaged.ads +++ b/gcc/ada/libgnat/s-imaged.ads @@ -36,6 +36,7 @@ generic type Int is range <>; + type Uns is mod <>; package System.Image_D is @@ -46,8 +47,8 @@ package System.Image_D is Scale : Integer); -- Computes fixed_type'Image (V), where V is the integer value (in units of -- delta) of a decimal type whose Scale is as given and stores the result - -- S (1 .. P), updating P to the value of L. The image is given by the - -- rules in RM 3.5(34) for fixed-point type image functions. The caller + -- S (1 .. P), updating P on return. The result is computed according to + -- the rules for image for fixed-point types (RM 3.5(34)). The caller -- guarantees that S is long enough to hold the result and has a lower -- bound of 1. diff --git a/gcc/ada/lib
[COMMITTED] ada: Remove guards against traversal of empty list of aspects
From: Piotr Trojanek When iterating over Aspect_Specifications, we can use First/Next directly even if the Aspect_Specifications returns a No_List or the list has no items. Code cleanup. gcc/ada/ * aspects.adb (Copy_Aspects): Style fix. * contracts.adb (Analyze_Contracts): Style fix. (Save_Global_References_In_Contract): Remove extra guards. * par_sco.adb (Traverse_Aspects): Move guard to the caller and make it consistent with Save_Global_References_In_Contract. * sem_ch12.adb (Has_Contracts): Remove extra guards. * sem_ch3.adb (Delayed_Aspect_Present, Get_Partial_View_Aspect, Check_Duplicate_Aspects): Likewise. * sem_disp.adb (Check_Dispatching_Operation): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/aspects.adb | 1 - gcc/ada/contracts.adb | 5 +-- gcc/ada/par_sco.adb | 8 ++-- gcc/ada/sem_ch12.adb | 22 +-- gcc/ada/sem_ch3.adb | 91 --- gcc/ada/sem_disp.adb | 22 +-- 6 files changed, 65 insertions(+), 84 deletions(-) diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 696ee672acd..b7262c56f3f 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -433,7 +433,6 @@ package body Aspects is --- procedure Copy_Aspects (From : Node_Id; To : Node_Id) is - begin if not Has_Aspects (From) then return; diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 97f38735662..810b360fb94 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -512,7 +512,6 @@ package body Contracts is if Present (It) then Validate_Iterable_Aspect (E, It); end if; - if Present (I_Lit) then Validate_Literal_Aspect (E, I_Lit); end if; @@ -4980,9 +4979,7 @@ package body Contracts is Push_Scope (Gen_Id); - if Permits_Aspect_Specifications (Templ) -and then Has_Aspects (Templ) - then + if Permits_Aspect_Specifications (Templ) then Save_Global_References_In_Aspects (Templ); end if; diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 83c1d001ee5..0b750a6f8de 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -1696,10 +1696,6 @@ package body Par_SCO is C1 : Character; begin - if not Has_Aspects (N) then -return; - end if; - AN := First (Aspect_Specifications (N)); while Present (AN) loop AE := Expression (AN); @@ -2414,7 +2410,9 @@ package body Par_SCO is end if; end case; - Traverse_Aspects (N); + if Permits_Aspect_Specifications (N) then +Traverse_Aspects (N); + end if; end Traverse_One; -- Start of processing for Traverse_Declarations_Or_Statements diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e7b759c4e88..cb05a71e96f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -9663,21 +9663,17 @@ package body Sem_Ch12 is A_Spec : Node_Id; A_Id : Aspect_Id; begin - if No (A_List) then - return False; - else - A_Spec := First (A_List); - while Present (A_Spec) loop -A_Id := Get_Aspect_Id (A_Spec); -if A_Id = Aspect_Pre or else A_Id = Aspect_Post then - return True; -end if; + A_Spec := First (A_List); + while Present (A_Spec) loop + A_Id := Get_Aspect_Id (A_Spec); + if A_Id = Aspect_Pre or else A_Id = Aspect_Post then +return True; + end if; -Next (A_Spec); - end loop; + Next (A_Spec); + end loop; - return False; - end if; + return False; end Has_Contracts; -- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1d95b12ff44..2bff0bb6307 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4153,24 +4153,22 @@ package body Sem_Ch3 is A_Id : Aspect_Id; begin - if Present (Aspect_Specifications (N)) then -A := First (Aspect_Specifications (N)); + A := First (Aspect_Specifications (N)); -while Present (A) loop - A_Id := Get_Aspect_Id (Chars (Identifier (A))); + while Present (A) loop +A_Id := Get_Aspect_Id (Chars (Identifier (A))); - if A_Id = Aspect_Address then +if A_Id = Aspect_Address then - -- Set flag on object entity, for later processing at - -- the freeze point. + -- Set flag on object entity, for later processing at the + -- freeze point. - Set_Has_Delayed_Aspects (Id); - return True; - end if; + Set_Has_Delayed_Aspects (Id); + return T
[COMMITTED] ada: Deconstruct unused flag Is_Expanded_Contract
From: Piotr Trojanek Flag Is_Expanded_Contract was introduced together with N_Contract field (when implementing freezing of contracts), but was never actually used. gcc/ada/ * gen_il-fields.ads (Opt_Field_Enum): Remove Is_Expanded_Contract from the list of flags. * gen_il-gen-gen_nodes.adb (N_Contract): Remove Is_Expanded_Contract from the list of N_Contract fields. * sinfo.ads (Is_Expanded_Contract): Remove comments for the flag and its single occurrence in N_Contract. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gen_il-fields.ads| 1 - gcc/ada/gen_il-gen-gen_nodes.adb | 1 - gcc/ada/sinfo.ads| 5 - 3 files changed, 7 deletions(-) diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 594aeb68819..67074c60250 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -254,7 +254,6 @@ package Gen_IL.Fields is Is_Elsif, Is_Entry_Barrier_Function, Is_Expanded_Build_In_Place_Call, - Is_Expanded_Contract, Is_Folded_In_Parser, Is_Generic_Contract_Pragma, Is_Homogeneous_Aggregate, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index fb00993a95e..3a78ffb2009 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -1330,7 +1330,6 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Contract, Node_Kind, (Sm (Classifications, Node_Id), Sm (Contract_Test_Cases, Node_Id), -Sm (Is_Expanded_Contract, Flag), Sm (Pre_Post_Conditions, Node_Id))); Cc (N_Derived_Type_Definition, Node_Kind, diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 06b9ad0884e..bee4491efde 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1720,10 +1720,6 @@ package Sinfo is --actuals to support a build-in-place style of call have been added to --the call. - -- Is_Expanded_Contract - --Present in N_Contract nodes. Set if the contract has already undergone - --expansion activities. - -- Is_Generic_Contract_Pragma --This flag is present in N_Pragma nodes. It is set when the pragma is --a source construct, applies to a generic unit or its body, and denotes @@ -7959,7 +7955,6 @@ package Sinfo is -- Pre_Post_Conditions (set to Empty if none) -- Contract_Test_Cases (set to Empty if none) -- Classifications (set to Empty if none) - -- Is_Expanded_Contract -- Pre_Post_Conditions contains a collection of pragmas that correspond -- to pre- and postconditions associated with an entry or a subprogram -- 2.43.2
[COMMITTED] ada: Move Init_Proc_Level_Formal from Exp_Ch3 to Exp_Util
From: Eric Botcazou This makes it possible to remove clauses from the Accessibility package. gcc/ada/ * accessibility.adb: Remove clauses for Exp_Ch3. * exp_ch3.ads (Init_Proc_Level_Formal): Move declaration to... * exp_ch3.adb (Init_Proc_Level_Formal): Move body to... * exp_util.ads (Init_Proc_Level_Formal): ...here. (Inside_Init_Proc): Alphabetize. * exp_util.adb (Init_Proc_Level_Formal): ...here. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/accessibility.adb | 1 - gcc/ada/exp_ch3.adb | 25 - gcc/ada/exp_ch3.ads | 5 - gcc/ada/exp_util.adb | 26 ++ gcc/ada/exp_util.ads | 10 +++--- 5 files changed, 33 insertions(+), 34 deletions(-) diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 75ab9667436..bb81ae49f41 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -32,7 +32,6 @@ with Elists; use Elists; with Errout; use Errout; with Einfo.Utils;use Einfo.Utils; with Exp_Atag; use Exp_Atag; -with Exp_Ch3;use Exp_Ch3; with Exp_Ch7;use Exp_Ch7; with Exp_Tss;use Exp_Tss; with Exp_Util; use Exp_Util; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f9989373a62..2477a221c96 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1462,31 +1462,6 @@ package body Exp_Ch3 is return Agg; end Build_Equivalent_Record_Aggregate; - - -- Init_Proc_Level_Formal -- - - - function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is - Form : Entity_Id; - begin - -- Move through the formals of the initialization procedure Proc to find - -- the extra accessibility level parameter associated with the object - -- being initialized. - - Form := First_Formal (Proc); - while Present (Form) loop - if Chars (Form) = Name_uInit_Level then -return Form; - end if; - - Next_Formal (Form); - end loop; - - -- No formal was found, return Empty - - return Empty; - end Init_Proc_Level_Formal; - --- -- Build_Initialization_Call -- --- diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 5a4b1133916..1e0f76ae18f 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -146,11 +146,6 @@ package Exp_Ch3 is -- type is valid only when Normalize_Scalars or Initialize_Scalars is -- active, or if N is the node for a 'Invalid_Value attribute node. - function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id; - -- Fetch the extra formal from an initalization procedure "proc" - -- corresponding to the level of the object being initialized. When none - -- is present Empty is returned. - procedure Init_Secondary_Tags (Typ: Entity_Id; Target : Node_Id; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index efc9ef0ed38..1dcfb61b333 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7267,6 +7267,32 @@ package body Exp_Util is return False; end In_Unconditional_Context; + + -- Init_Proc_Level_Formal -- + + + function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is + Form : Entity_Id; + + begin + -- Go through the formals of the initialization procedure Proc to find + -- the extra accessibility level parameter associated with the object + -- being initialized. + + Form := First_Formal (Proc); + while Present (Form) loop + if Chars (Form) = Name_uInit_Level then +return Form; + end if; + + Next_Formal (Form); + end loop; + + -- No formal was found, return Empty + + return Empty; + end Init_Proc_Level_Formal; + --- -- Insert_Action -- --- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index b968f448bba..3fd3a151ddb 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -724,9 +724,6 @@ package Exp_Util is -- chain, counting only entries in the current scope. If an entity is not -- overloaded, the returned number will be one. - function Inside_Init_Proc return Boolean; - -- Returns True if current scope is within an init proc - function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean; -- Given an arbitrary entity, determine whether it appears at the library -- level of a package body. @@ -737,6 +734,13 @@ package Exp_Util is -- unconditionally executed, i.e. it is not within a loop or a conditional -- or a case statement etc. + function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id; + -- Return the extra formal of an initialization proce
[COMMITTED] ada: Move splitting of pre/post aspect expressions to expansion
From: Piotr Trojanek
We split expressions of pre/post aspects into individual conjuncts and
emit messages with their precise location when they fail at runtime.
This was done when processing the aspects and caused inefficiency when
the original expression had to be recovered to detects uses of 'Old that
changed in Ada 2022. This patch moves splitting to expansion.
Conceptually, splitting in expansion is easy, but we need to take care
of locations for inherited pre/post contracts. Previously the location
string was generated while splitting the aspect into pragmas and then
it was manipulated when inheriting the pragmas. Now the location string
is built when installing the Pre'Class check and when splitting the
expression in expansion.
gcc/ada/
* exp_ch6.adb (Append_Message): Build the location string from
scratch and not rely on the one produced while splitting the
aspect into pragmas.
* exp_prag.adb (Expand_Pragma_Check): Split pre/post checks in
expansion.
* sem_ch13.adb (Analyze_Aspect_Specification): Don't split
pre/post expressions into conjuncts; don't add message with
location to the corresponding pragma.
* sem_prag.adb (Build_Pragma_Check_Equivalent): Inherited
pragmas no longer have messages that would need to be updated.
* sinput.adb (Build_Location_String): Adjust to keep previous
messages while using with inherited pragmas.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch6.adb | 45 +++
gcc/ada/exp_prag.adb | 279 +--
gcc/ada/sem_ch13.adb | 52
gcc/ada/sem_prag.adb | 18 ---
gcc/ada/sinput.adb | 21 +++-
5 files changed, 224 insertions(+), 191 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 1ed83255a6d..97be99d6661 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -78,7 +78,6 @@ with Sinfo.Utils;use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
-with Stringt;use Stringt;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw;use Validsw;
@@ -7677,47 +7676,37 @@ package body Exp_Ch6 is
(Id : Entity_Id;
Is_First : in out Boolean)
is
-Prag : constant Node_Id := Get_Class_Wide_Pragma (Id,
- Pragma_Precondition);
-Msg: Node_Id;
-Str_Id : String_Id;
+Prag : constant Node_Id :=
+ Get_Class_Wide_Pragma (Id, Pragma_Precondition);
begin
if No (Prag) or else Is_Ignored (Prag) then
return;
end if;
-Msg:= Expression (Last (Pragma_Argument_Associations (Prag)));
-Str_Id := Strval (Msg);
-
if Is_First then
Is_First := False;
- Append (Global_Name_Buffer, Strval (Msg));
-
- if Id /= Subp_Id
- and then Name_Buffer (1 .. 19) = "failed precondition"
- then
- Insert_Str_In_Name_Buffer ("inherited ", 8);
+ if Id /= Subp_Id then
+ Append
+(Global_Name_Buffer, "failed inherited precondition ");
+ else
+ Append (Global_Name_Buffer, "failed precondition ");
end if;
else
- declare
- Str : constant String := To_String (Str_Id);
- From_Idx : Integer;
+ Append (Global_Name_Buffer, ASCII.LF);
+ Append (Global_Name_Buffer, " or ");
- begin
- Append (Global_Name_Buffer, ASCII.LF);
- Append (Global_Name_Buffer, " or ");
-
- From_Idx := Name_Len;
- Append (Global_Name_Buffer, Str_Id);
-
- if Str (1 .. 19) = "failed precondition" then
- Insert_Str_In_Name_Buffer ("inherited ", From_Idx + 8);
- end if;
- end;
+ Append (Global_Name_Buffer, "failed inherited precondition ");
end if;
+
+Append (Global_Name_Buffer, "from " &
+ Build_Location_String
+(Sloc
+ (First_Node
+ (Expression
+(First (Pragma_Argument_Associations (Prag)));
end Append_Message;
-- Local variables
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 78490dcbf45..a9379025a6b 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -284,24 +284,6 @@ package body Exp_Prag is
--
procedure Expand_Pragma_Check (N : Node_Id) is
- Cond : constant Node_Id := Arg_N (N, 2);
- Nam : constant Name_Id := Chars (Arg_N (N, 1));
- Msg : Node_Id;
-
-
[COMMITTED] ada: Complete implementation of Ada 2022 aspect Exclusive_Functions
From: Piotr Trojanek Extend implementation of RM 9.5.1(7/4), which now applies also to protected function if the protected type has aspect Exclusive_Functions. gcc/ada/ * exp_ch9.adb (Build_Protected_Subprogram_Call_Cleanup): If aspect Exclusive_Functions is present then the cleanup of a protected function now services queued entries, just like the cleanup of a protected procedure. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch9.adb | 19 --- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 17d997b9f60..1b231b8bf2c 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4032,12 +4032,25 @@ package body Exp_Ch9 is Nam : Node_Id; begin - -- If the associated protected object has entries, a protected - -- procedure has to service entry queues. In this case generate: + -- If the associated protected object has entries, the expanded + -- exclusive protected operation has to service entry queues. In + -- this case generate: --Service_Entries (_object._object'Access); - if Nkind (Op_Spec) = N_Procedure_Specification + if (Nkind (Op_Spec) = N_Procedure_Specification +or else + (Nkind (Op_Spec) = N_Function_Specification + and then Has_Aspect (Conc_Typ, Aspect_Exclusive_Functions) + and then + (No + (Find_Value_Of_Aspect (Conc_Typ, +Aspect_Exclusive_Functions)) + or else +Is_True + (Static_Boolean + (Find_Value_Of_Aspect +(Conc_Typ, Aspect_Exclusive_Functions)) and then Has_Entries (Conc_Typ) then case Corresponding_Runtime_Package (Conc_Typ) is -- 2.43.2
[COMMITTED] ada: Deconstruct flag Split_PPC since splitting now is done in expansion
From: Piotr Trojanek Remove flag Split_PPC and all its uses. gcc/ada/ * contracts.adb (Append_Enabled_Item): Remove use of Split_PPC; simplify. * gen_il-fields.ads (Opt_Field_Enum): Remove flag definition. * gen_il-gen-gen_nodes.adb (N_Aspect_Specification, N_Pragma): Remove Split_PPC flags. * gen_il-internals.adb (Image): Remove use of Split_PPC. * par_sco.adb (Traverse_Aspects): Likewise. * sem_ch13.adb (Make_Aitem_Pragma): Likewise. * sem_ch6.adb (List_Inherited_Pre_Post_Aspects): Likewise. * sem_prag.adb (Analyze_Pre_Post_Condition, Analyze_Pragma, Find_Related_Declaration_Or_Body): Likewise. * sem_util.adb (Applied_On_Conjunct): Likewise. * sinfo.ads: Remove flag documentation. * treepr.adb (Image): Remove use of Split_PPC. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb| 17 +--- gcc/ada/gen_il-fields.ads| 1 - gcc/ada/gen_il-gen-gen_nodes.adb | 2 - gcc/ada/gen_il-internals.adb | 2 - gcc/ada/par_sco.adb | 5 --- gcc/ada/sem_ch13.adb | 15 +++ gcc/ada/sem_ch6.adb | 4 +- gcc/ada/sem_prag.adb | 8 +--- gcc/ada/sem_util.adb | 73 ++-- gcc/ada/sinfo.ads| 19 + gcc/ada/treepr.adb | 2 - 11 files changed, 25 insertions(+), 123 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index c04d850b532..97f38735662 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -2714,22 +2714,7 @@ package body Contracts is -- Otherwise, add the item else -if No (List) then - List := New_List; -end if; - --- If the pragma is a conjunct in a composite postcondition, it --- has been processed in reverse order. In the postcondition body --- it must appear before the others. - -if Nkind (Item) = N_Pragma - and then From_Aspect_Specification (Item) - and then Split_PPC (Item) -then - Prepend (Item, List); -else - Append (Item, List); -end if; +Append_New (Item, List); end if; end Append_Enabled_Item; diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 67074c60250..54a5703d1a5 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -386,7 +386,6 @@ package Gen_IL.Fields is Shift_Count_OK, Source_Type, Specification, - Split_PPC, Statements, Storage_Pool, Subpool_Handle_Name, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 3a78ffb2009..f3dc215673a 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -1251,7 +1251,6 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Identifier, Node_Id, Default_Empty), Sy (Expression, Node_Id, Default_Empty), Sy (Class_Present, Flag), -Sy (Split_PPC, Flag), Sm (Aspect_On_Partial_View, Flag), Sm (Aspect_Rep_Item, Node_Id), Sm (Entity_Or_Associated_Node, Node_Id), -- just Entity @@ -1556,7 +1555,6 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Pragma_Argument_Associations, List_Id, Default_No_List), Sy (Pragma_Identifier, Node_Id), Sy (Class_Present, Flag), -Sy (Split_PPC, Flag), Sm (Corresponding_Aspect, Node_Id), Sm (From_Aspect_Specification, Flag), Sm (Import_Interface_Present, Flag), diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index a0f55d39a42..e08397f7d4e 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -339,8 +339,6 @@ package body Gen_IL.Internals is return "SPARK_Pragma"; when SPARK_Pragma_Inherited => return "SPARK_Pragma_Inherited"; - when Split_PPC => -return "Split_PPC"; when SSO_Set_High_By_Default => return "SSO_Set_High_By_Default"; when SSO_Set_Low_By_Default => diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 144c1382369..83c1d001ee5 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -1704,11 +1704,6 @@ package body Par_SCO is while Present (AN) loop AE := Expression (AN); --- SCOs are generated before semantic analysis/expansion: --- PPCs are not split yet. - -pragma Assert (not Split_PPC (AN)); - C1 := ASCII.NUL; case Get_Aspect_Id (AN) is diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index efbc67f3c5d..0470ce10ac7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1776,12 +1776,12 @@ package body Sem_Ch13 is Pragma_Name : Name_Id) retur
[COMMITTED] ada: Avoid crash on illegal constrained type declarations
From: Piotr Trojanek Fix crash on ACATS test B38003B introduced by a recent cleanup of per-object constraints. gcc/ada/ * sem_util.adb (Get_Index_Bounds): Guard against missing Entity, which happens on illegal constrained type declaration. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 5 - 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5f44b4c26fe..579172515df 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10542,7 +10542,10 @@ package body Sem_Util is H := High_Bound (Range_Expression (Constraint (N))); end if; - elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then + elsif Is_Entity_Name (N) +and then Present (Entity (N)) +and then Is_Type (Entity (N)) + then Rng := Scalar_Range_Of_Type (Entity (N)); if Error_Posted (Rng) then -- 2.43.2
[COMMITTED] ada: Fix style in comments
From: Piotr Trojanek Code cleanup. gcc/ada/ * contracts.adb (Inherit_Subprogram_Contract): Fix style. * sem_ch5.adb (Analyze_Iterator_Specification): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 2 +- gcc/ada/sem_ch5.adb | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index c440053bb78..c04d850b532 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -3620,7 +3620,7 @@ package body Contracts is end if; end Inherit_Pragma; - -- Start of processing for Inherit_Subprogram_Contract + -- Start of processing for Inherit_Subprogram_Contract begin -- Inheritance is carried out only when both entities are subprograms diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index dc9524b0891..2677a2c5a1c 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2158,7 +2158,7 @@ package body Sem_Ch5 is return Etype (Ent); end Get_Cursor_Type; - -- Start of processing for Analyze_Iterator_Specification + -- Start of processing for Analyze_Iterator_Specification begin Enter_Name (Def_Id); -- 2.43.2
[COMMITTED] ada: Decouple finalization masters from storage pools
From: Eric Botcazou The coupling came from the build-in-place protocol but is now unnecessary because the storage pool reference is always passed along with the master reference in this protocol. No functional changes. gcc/ada/ * exp_ch3.adb (Build_Heap_Or_Pool_Allocator): Use the BIPstoragepool formal parameter to retrieve the pool in the presence of a master. * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Always pass a pool reference along with the master reference. (Make_Build_In_Place_Call_In_Object_Declaration): Likewise. * exp_ch7.adb (Build_BIP_Cleanup_Stmts): Use the BIPstoragepool formal parameter to retrieve the pool in the presence of a master. (Create_Anonymous_Master): Do not call Set_Base_Pool. (Build_Finalization_Master): Likewise. * rtsfind.ads (RE_Id): Remove RE_Base_Pool and RE_Set_Base_Pool. (RE_Unit_Table): Remove associated entries. * libgnat/s-finmas.ads: Remove clause for System.Storage_Pools. (Any_Storage_Pool_Ptr): Delete. (Finalization_Master): Remove Base_Pool component. (Base_Pool): Delete. (Set_Base_Pool): Likewise. * libgnat/s-finmas.adb (Base_Pool): Likewise. (Set_Base_Pool): Likewise. (Print_Master): Do not print Base_Pool. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 49 +++--- gcc/ada/exp_ch6.adb | 33 --- gcc/ada/exp_ch7.adb | 79 gcc/ada/libgnat/s-finmas.adb | 30 -- gcc/ada/libgnat/s-finmas.ads | 22 -- gcc/ada/rtsfind.ads | 4 -- 6 files changed, 76 insertions(+), 141 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4ebc7b977e9..f8d41b1bfc0 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6254,8 +6254,7 @@ package body Exp_Ch3 is -- else -- declare -- type Ptr_Typ is access Ret_Typ; - -- for Ptr_Typ'Storage_Pool use - -- Base_Pool (BIPfinalizationmaster.all).all; + -- for Ptr_Typ'Storage_Pool use BIPstoragepool.all; -- Local : Ptr_Typ; -- -- begin @@ -6497,25 +6496,27 @@ package body Exp_Ch3 is begin -- Generate: - --Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; - - Pool_Id := Make_Temporary (Loc, 'P'); - - Append_To (Decls, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Pool_Id, - Subtype_Mark=> - New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), - Name=> - Make_Explicit_Dereference (Loc, - Prefix => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Base_Pool), Loc), - Parameter_Associations => New_List ( - Make_Explicit_Dereference (Loc, - Prefix => - New_Occurrence_Of (Fin_Mas_Id, Loc))); + --Pool_Id renames BIPstoragepool.all; + + -- This formal is not added on ZFP as those targets do not + -- support pools. + + if RTE_Available (RE_Root_Storage_Pool_Ptr) then + Pool_Id := Make_Temporary (Loc, 'P'); + + Append_To (Decls, +Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool_Id, + Subtype_Mark=> +New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), + Name=> +Make_Explicit_Dereference (Loc, + New_Occurrence_Of +(Build_In_Place_Formal + (Func_Id, BIP_Storage_Pool), Loc; + else + Pool_Id := Empty; + end if; -- Create an access type which uses the storage pool of the -- caller's master. This additional type is necessary because @@ -6572,10 +6573,8 @@ package body Exp_Ch3 is Unchecked_Convert_To (Temp_Typ, New_Occurrence_Of (Local_Id, Loc; - -- Wrap the allocation in a block. This is further conditioned - -- by checking the caller finalization master at runtime. A - -- null value indicates a non-existent master, most likely due - -- to a Finalize_Storage_Only allocation. + -- Wrap the allocation in a block to make it conditioned
[COMMITTED] ada: Rename finalization scope masters into finalization masters
From: Eric Botcazou Now that what was previously called "finalization master" has been renamed into "finalization collection" in the front-end, we can also rename what was initially called "finalization scope master" into "finalization master". These entities indeed drive the finalization of all the objects that require it, directly for (statically) declared objects or indirectly for dynamically allocated objects (that is to say, through finalization collections). gcc/ada/ * exp_ch7.adb: Adjust the description of finalization management. (Build_Finalizer): Rename scope master into master throughout. * rtsfind.ads (RE_Id): Replace RE_Finalization_Scope_Master with RE_Finalization_Master. (RE_Unit_Table): Replace entry for RE_Finalization_Scope_Master with entry for RE_Finalization_Master. * libgnat/s-finpri.ads (Finalization_Scope_Master): Rename into... (Finalization_Master): ...this. (Attach_Object_To_Master): Adjust to above renaming. (Chain_Node_To_Master): Likewise. (Finalize_Master): Likewise. * libgnat/s-finpri.adb (Attach_Object_To_Master): Likewise. (Chain_Node_To_Master): Likewise. (Finalize_Master): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch7.adb | 64 +--- gcc/ada/libgnat/s-finpri.adb | 6 ++-- gcc/ada/libgnat/s-finpri.ads | 12 +++ gcc/ada/rtsfind.ads | 4 +-- 4 files changed, 42 insertions(+), 44 deletions(-) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 50d5359e04d..a62c7441a48 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -85,10 +85,9 @@ package body Exp_Ch7 is -- Initialize calls: they are generated for either declarations or dynamic -- allocations of controlled objects with no initial value. They are always - -- followed by an attachment to the current finalization chain. For the - -- dynamic allocation case, this is the chain attached to the scope of the - -- access type definition; otherwise, this is the chain of the current - -- scope. + -- followed by an attachment to some finalization chain. For the dynamic + -- dynamic allocation case, this is the collection attached to the access + -- type definition; otherwise, this is the master of the current scope. -- Adjust calls: they are generated on two occasions: (1) for declarations -- or dynamic allocations of controlled objects with an initial value (with @@ -122,7 +121,7 @@ package body Exp_Ch7 is -- is expanded into: -- --declare - -- Mnn : System.Finalization_Primitives.Finalization_Scope_Master; + -- Mnn : System.Finalization_Primitives.Finalization_Master; -- XMN : aliased System.Finalization_Primitives.Master_Node; -- X : Ctrl; @@ -203,8 +202,8 @@ package body Exp_Ch7 is --at end -- _Finalizer; - -- In the case of a block containing a single controlled object, the scope - -- master degenerates into a single master node: + -- In the case of a block containing a single controlled object, the master + -- degenerates into a single master node: --declare -- X : Ctrl := Init; @@ -268,7 +267,7 @@ package body Exp_Ch7 is -- These direct actions must be signalled to the post-processing machinery -- and this is achieved through the handling of Master_Node objects, which - -- are the items actually chained in finalization chains of scope masters. + -- are the items actually chained in the finalization chains of masters. -- With the default processing, they are created by Build_Finalizer for the -- controlled objects spotted by Requires_Cleanup_Actions. But when direct -- actions are carried out, they are generated by these actions and later @@ -1702,8 +1701,8 @@ package body Exp_Ch7 is Finalizer_Decls : List_Id := No_List; -- Local variable declarations - Finalization_Scope_Master : Entity_Id; - -- The Finalization Scope Master object + Finalization_Master : Entity_Id; + -- The Finalization Master object Finalizer_Stmts : List_Id := No_List; -- The statement list of the finalizer body @@ -1774,33 +1773,33 @@ package body Exp_Ch7 is -- procedure Build_Components is - Constraints : List_Id; - Scope_Master_Decl : Node_Id; - Scope_Master_Name : Name_Id; + Constraints : List_Id; + Master_Decl : Node_Id; + Master_Name : Name_Id; begin pragma Assert (Present (Decls)); -- If the context contains controlled objects, then we create the - -- finalization scope master, unless there is a single such object; - -- in this common case, we'll directly finalize the object. + -- finalization master, unless there is a single such object:
[COMMITTED] ada: Replace finalization masters with finalization collections
From: Eric Botcazou This change replaces finalization masters with finalization collections in most cases, that is to say, when they implement a list of objects created by allocators of a given access type; indeed the moniker is overloaded in the front-end, e.g. Sem_Util.Is_Master determines if a node "constitutes a finalization master" but is not affected by the change. This is mostly a renaming at this stage, toward something more in keeping with the terminology used in the RM 7.6.1 clause and no functional changes: although it gets rid of the rest of the System.Finalization_Masters unit, the functionalities are reimplemented in the System.Finalization_Primitives unit in terms of collections with only minor adjustments. gcc/ada/ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Remove s-finmas$(objext). * einfo.ads (Anonymous_Masters): Rename into Anonymous_Collections. (Finalization_Master): Rename into Finalization_Collection. * gen_il-fields.ads (Opt_Field_Enum): Replace Anonymous_Masters with Anonymous_Collections; and Finalization_Master with Finalization_Collection. * gen_il-gen-gen_entities.adb (Access_Kind): Likewise. (E_Function): Likewise. (E_Procedure): Likewise. (E_Package): Likewise. (E_Subprogram_Body): Likewise. * exp_ch3.adb (Build_Heap_Or_Pool_Allocator): Adjust to renamings. (Freeze_Type): Likewise. (Stream_Operation_OK): Remove obsolete test. * exp_ch4.adb (Expand_Allocator_Expression): Adjust to renamings. (Expand_N_Allocator): Likewise. * exp_ch6.ads (BIP_Formal_Kind): Replace BIP_Finalization_Master with BIP_Collection. (Needs_BIP_Finalization_Master): Rename into... (Needs_BIP_Collection): ...this. * exp_ch6.adb (BIP_Finalization_Master_Suffix): Delete. (BIP_Collection_Suffix): New constant string. (Add_Finalization_Master_Actual_To_Build_In_Place_Call): Rename to (Add_Collection_Actual_To_Build_In_Place_Call): ...this and adjust. (BIP_Formal_Suffix): Replace BIP_Finalization_Master alternative with BIP_Collection alternative. (BIP_Suffix_Kind): Replace test on BIP_Finalization_Master_Suffix with test on BIP_Collection_Suffix. (Is_Build_In_Place_Entity): Likewise. (Make_Build_In_Place_Call_In_Allocator): Call Needs_BIP_Collection and Add_Collection_Actual_To_Build_In_Place_Call. (Make_Build_In_Place_Call_In_Anonymous_Context): Likewise. (Make_Build_In_Place_Call_In_Assignment): Likewise. (Make_Build_In_Place_Call_In_Object_Declaration): Likewise. (Needs_BIP_Finalization_Master): Rename into... (Needs_BIP_Collection): ...this. (Needs_BIP_Alloc_Form): Call Needs_BIP_Collection. * exp_ch7.ads (Build_Anonymous_Master): Rename into... (Build_Anonymous_Collection): ...this. (Build_Finalization_Master): Rename into... (Build_Finalization_Collection): ...this. * exp_ch7.adb (Allows_Finalization_Master): Rename into... (Allows_Finalization_Collection): ...this. (Build_BIP_Cleanup_Stmts): Adjust to renamings. (Build_Anonymous_Master): Rename into... (Build_Anonymous_Collection): ...this. Adjust to renamings. (Build_Finalization_Master): Rename into... (Build_Finalization_Collection): ...this. Adjust to renamings. (Build_Finalizer): Adjust comment to renamings. * exp_ch13.adb (Expand_N_Free_Statement): Adjust to renamings. * exp_util.adb (Build_Allocate_Deallocate_Proc): Likewise. (Requires_Cleanup_Actions): Adjust comment to renamings. * freeze.adb (Freeze_All): Likewise. * rtsfind.ads (RTU_Id): Remove System_Finalization_Masters. (RE_Id): Remove RE_Finalization_Master & RE_Finalization_Master_Ptr add RE_Finalization_Collection & RE_Finalization_Collection_Ptr. Adjust RE_Add_Offset_To_Address and RE_Finalization_Scope_Master. (RE_Unit_Table): Remove entries for RE_Finalization_Master & RE_Finalization_Master_Ptr, add ones for RE_Finalization_Collection & RE_Finalization_Collection_Ptr. Also adjust those of RE_Add_Offset_To_Address and RE_Finalization_Scope_Master. * sem_ch3.adb (Access_Type_Declaration): Adjust to renamings. * sem_ch6.adb (Create_Extra_Formals): Likewise. * sem_util.adb (Designated_Subtype_Mark): Likewise. * libgnat/s-finpri.ads: Add clauses for Ada.Finalization and System.Storage_Elements. (Finalization_Collection): New limited controlled type. (Finalization_Collection_Ptr): Likewise. (Initialize): New overriding procedure. (Finalize): Likewise. (Finalization_Started): Likewise. (Collection_Node): New type. (Collection_Node_Ptr): Likewise. (Attach_Node_To_Collection): New procedure. (D
[COMMITTED] ada: Restore fix for controlled dynamic allocation with BIP function call
From: Eric Botcazou The resolution made some time ago had been that a dynamic allocation for a limited type that needs finalization with a function call as expression always needs to be done in the called function, even if the limited type has a known size. But the fix implementing this resolution was dropped inadvertently at some point. The change also contains a small tweak for Expand_N_Object_Declaration and a small related cleanup in the finalization machinery. gcc/ada/ * exp_ch3.adb (Expand_N_Object_Declaration): In the case of a return object of a BIP function that needs finalization, save the assignment statement made to initialize it, if any. * exp_ch6.ads (BIP_Formal_Kind): Adjust description. * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Make a couple of adjustments to the commentary. (Needs_BIP_Alloc_Form): Also return true if the function needs a BIP_Finalization_Master parameter. * exp_ch7.adb (Build_BIP_Cleanup_Stmts): Remove now always true test on Needs_BIP_Alloc_Form. (Attach_Object_To_Master_Node): Remove duplication in comment. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 8 + gcc/ada/exp_ch6.adb | 34 ++-- gcc/ada/exp_ch6.ads | 22 +++-- gcc/ada/exp_ch7.adb | 75 - 4 files changed, 64 insertions(+), 75 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f934dbfddaa..4ebc7b977e9 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8746,6 +8746,14 @@ package body Exp_Ch3 is Initialize_Return_Object (Tag_Assign, Adj_Call, Expr_Q, Init_Stmt, Init_After); +-- Save the assignment statement when returning a controlled +-- object. This reference is used later by the finalization +-- machinery to mark the object as successfully initialized. + +if Present (Init_Stmt) and then Needs_Finalization (Typ) then + Set_Last_Aggregate_Assignment (Def_Id, Init_Stmt); +end if; + -- Replace the return object declaration with a renaming of a -- dereference of the access value designating the return object. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index a89c9af0bb2..9e1844aa08e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -158,9 +158,9 @@ package body Exp_Ch6 is Alloc_Form : BIP_Allocation_Form := Unspecified; Alloc_Form_Exp : Node_Id := Empty; Pool_Actual: Node_Id := Make_Null (No_Location)); - -- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place - -- function call that returns a caller-unknown-size result (BIP_Alloc_Form - -- and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it, + -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs + -- them, add the actuals parameters BIP_Alloc_Form and BIP_Storage_Pool. + -- If Alloc_Form_Exp is present, then pass it for the first parameter, -- otherwise pass a literal corresponding to the Alloc_Form parameter -- (which must not be Unspecified in that case). Pool_Actual is the -- parameter to pass to BIP_Storage_Pool. @@ -8328,9 +8328,11 @@ package body Exp_Ch6 is Set_Can_Never_Be_Null (Acc_Type, False); -- It gets initialized to null, so we can't have that - -- When the result subtype is constrained, the return object is created - -- on the caller side, and access to it is passed to the function. This - -- optimization is disabled when the result subtype needs finalization + -- When the result subtype is returned on the secondary stack or is + -- tagged, the called function itself must perform the allocation of + -- the return object, so we pass parameters indicating that. + + -- But that's also the case when the result subtype needs finalization -- actions because the caller side allocation may result in undesirable -- finalization. Consider the following example: -- @@ -8351,11 +8353,6 @@ package body Exp_Ch6 is -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope -- since it is already attached on the related finalization master. - -- Here and in related routines, we must examine the full view of the - -- type, because the view at the point of call may differ from the - -- one in the function body, and the expansion mechanism depends on - -- the characteristics of the full view. - if Needs_BIP_Alloc_Form (Function_Id) then Temp_Init := Empty; @@ -8386,6 +8383,10 @@ package body Exp_Ch6 is Return_Obj_Actual := Empty; + -- When the result subtype neither is returned on the secondary stack + -- nor is tagged, the return object is created on the caller
[COMMITTED] ada: Couple of comment tweaks to latest change
From: Eric Botcazou This replaces a few remaining references to "master" by "collection" and makes a couple of additional tweaks in comments. gcc/ada/ * libgnat/s-finpri.adb (Finalize): Replace "master" by "collection" in comments and add a comment about the form of the loop. * libgnat/s-stposu.adb (Allocate_Any_Controlled): Tweak comment. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-finpri.adb | 20 gcc/ada/libgnat/s-stposu.adb | 9 - 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb index 2abc9f49403..731c913b2e7 100644 --- a/gcc/ada/libgnat/s-finpri.adb +++ b/gcc/ada/libgnat/s-finpri.adb @@ -174,18 +174,16 @@ package body System.Finalization_Primitives is if Collection.Finalization_Started then Unlock_Task.all; - -- Double finalization may occur during the handling of stand alone - -- libraries or the finalization of a pool with subpools. Due to the - -- potential aliasing of masters in these two cases, do not process - -- the same master twice. + -- Double finalization may occur during the handling of stand-alone + -- libraries or the finalization of a pool with subpools. return; end if; - -- Lock the master to prevent any allocations while the objects are - -- being finalized. The master remains locked because either the master - -- is explicitly deallocated or the associated access type is about to - -- go out of scope. + -- Lock the collection to prevent any allocation while the objects are + -- being finalized. The collection remains locked because either it is + -- explicitly deallocated or the associated access type is about to go + -- out of scope. -- Synchronization: --Read - allocation, finalization @@ -193,6 +191,12 @@ package body System.Finalization_Primitives is Collection.Finalization_Started := True; + -- Note that we cannot walk the list while finalizing its elements + -- because the finalization of one may call Unchecked_Deallocation + -- on another and, therefore, detach it from anywhere on the list. + -- Instead, we empty the list by repeatedly finalizing the first + -- element (after the dummy head) and detaching it from the list. + while not Is_Empty_List (Collection.Head'Unchecked_Access) loop Curr_Ptr := Collection.Head.Next; diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb index ebbd3e4d72a..8d232fa0d61 100644 --- a/gcc/ada/libgnat/s-stposu.adb +++ b/gcc/ada/libgnat/s-stposu.adb @@ -196,17 +196,16 @@ package body System.Storage_Pools.Subpools is -- object or a record with controlled components. if Is_Controlled then - - -- Synchronization: - --Read - allocation, finalization - --Write - finalization - Lock_Taken := True; Lock_Task.all; -- Do not allow the allocation of controlled objects while the -- associated collection is being finalized. + -- Synchronization: + --Read - allocation, finalization + --Write - finalization + if Finalization_Started (Collection.all) then raise Program_Error with "allocation after finalization started"; end if; -- 2.43.2
[COMMITTED] ada: Remove deprecated VxWorks interrupt connection API
From: Ashley Gay The VxWorks 7 API to use hardware interrupts is the VxBus subsystem. GNAT API still provides bindings for the deprecated (VxWorks 6) routines. A direct consequence of this change is that Attach_Handler cannot be used anymore (the VxBus subsystem should be used instead). This patch removes all the functions that are not supported by VxWorks 7 anymore. To warn for the usage of Attach_Handler, it adds the 'Obsolescent' pragma to to this routine so the comiler will advise the user if this function is called directly or through a pragma. gcc/ada/ * Makefile.rtl: remove i-vxinco.* from the build * doc/gnat_rm/the_gnat_library.rst: Remove i-vxinco.ads from the units documentation. * impunit.adb: Remove i-vxinco from the list of available units in GNATstudio. * libgnarl/i-vxinco.adb: Remove. * libgnarl/i-vxinco.ads: Ditto. * libgnarl/s-interr__vxworks.adb: enrich comment * libgnarl/s-vxwext__kernel.ads: fix comment * libgnat/i-vxwork.ads: Remove deprecated interrupt connections API, as well as an example. * libgnat/i-vxwork__x86.ads: Ditto and add the paragma Obscolescent to Attach_Handler * gnat_rm.texi: Regenerate. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 8 +- gcc/ada/doc/gnat_rm/the_gnat_library.rst | 17 -- gcc/ada/gnat_rm.texi | 196 ++- gcc/ada/impunit.adb | 1 - gcc/ada/libgnarl/i-vxinco.adb| 48 -- gcc/ada/libgnarl/i-vxinco.ads| 56 --- gcc/ada/libgnarl/s-interr__vxworks.adb | 5 +- gcc/ada/libgnarl/s-vxwext__kernel.ads| 2 +- gcc/ada/libgnat/i-vxwork.ads | 115 + gcc/ada/libgnat/i-vxwork__x86.ads| 109 - 10 files changed, 98 insertions(+), 459 deletions(-) delete mode 100644 gcc/ada/libgnarl/i-vxinco.adb delete mode 100644 gcc/ada/libgnarl/i-vxinco.ads diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 3721a70ffcc..ad3e6380a52 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1162,7 +1162,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7%, $(target_cpu) $(targe RTSERR = $(error NO SUCH RUNTIME) endif endif - EXTRA_GNATRTL_NONTASKING_OBJS+=i-vxinco.o i-vxwork.o i-vxwoio.o + EXTRA_GNATRTL_NONTASKING_OBJS+=i-vxwork.o i-vxwoio.o endif endif @@ -1279,7 +1279,7 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks7%, $(target_cpu) $(target_vend RTSERR = $(error NO SUCH RUNTIME) endif -EXTRA_GNATRTL_NONTASKING_OBJS += i-vxinco.o i-vxwork.o i-vxwoio.o +EXTRA_GNATRTL_NONTASKING_OBJS += i-vxwork.o i-vxwoio.o endif EXTRA_GNATRTL_NONTASKING_OBJS += s-stchop.o @@ -1371,7 +1371,7 @@ ifeq ($(strip $(filter-out aarch64 arm wrs vxworks7%, $(target_cpu) $(target_ven endif EXTRA_GNATRTL_NONTASKING_OBJS += i-vxwork.o i-vxwoio.o s-stchop.o - EXTRA_GNATRTL_TASKING_OBJS += i-vxinco.o s-vxwork.o s-vxwext.o + EXTRA_GNATRTL_TASKING_OBJS += s-vxwork.o s-vxwext.o EXTRA_LIBGNAT_OBJS+=vx_stack_info.o @@ -2890,7 +2890,7 @@ ADA_EXCLUDE_SRCS =\ g-allein.ads g-alleve.adb g-alleve.ads g-altcon.adb g-altcon.ads \ g-altive.ads g-alveop.adb g-alveop.ads g-alvety.ads g-alvevi.ads \ g-intpri.ads g-regist.adb g-regist.ads g-sse.adsg-ssvety.ads \ - i-vxinco.adb i-vxinco.ads i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \ + i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \ s-linux.ads s-vxwext.adb s-vxwext.ads s-win32.ads s-winext.ads \ s-stchop.ads s-stchop.adb \ s-strcom.adb s-strcom.ads s-thread.ads \ diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst index 3aae70a4409..88204d4cfe7 100644 --- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst +++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst @@ -1915,23 +1915,6 @@ mainframes. .. index:: VxWorks, interfacing This package provides a limited binding to the VxWorks API. -In particular, it interfaces with the -VxWorks hardware interrupt facilities. - -.. _`Interfaces.VxWorks.Int_Connection_(i-vxinco.ads)`: - -``Interfaces.VxWorks.Int_Connection`` (:file:`i-vxinco.ads`) - - -.. index:: Interfaces.VxWorks.Int_Connection (i-vxinco.ads) - -.. index:: Interfacing to VxWorks - -.. index:: VxWorks, interfacing - -This package provides a way for users to replace the use of -intConnect() with a custom routine for installing interrupt -handlers. .. _`Interfaces.VxWorks.IO_(i-vxwoio.ads)`: diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index f6b14cf61b9..f0e95bec1e5 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -833,7 +833,6 @@ The GNAT Library * Interfaces.C.Streams (i-cstrea.ads): Interfaces C Streams i-cstrea ads. * Interfaces.Packed_Decimal (i-pacdec.ads): Interfaces Packed_Decimal i-
[COMMITTED] ada: Fix pragma Compile_Time_Error for alignment of array types
From: Eric Botcazou The pragma is consistenly rejected for the alignment of array types because Eval_Attribute does not evaluate it even if it is known. gcc/ada/ * sem_attr.adb (Eval_Attribute): Treat Alignment like Component_Size for array types. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_attr.adb | 12 +++- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e80a144ebb2..65442d45a85 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -8729,14 +8729,15 @@ package body Sem_Attr is -- Unconstrained_Array are again exceptions, because they apply as well -- to unconstrained types. + -- Folding can also be done for Preelaborable_Initialization based on + -- whether the prefix type has preelaborable initialization, even though + -- the attribute is nonstatic. + -- In addition Component_Size is an exception since it is possibly -- foldable, even though it is never static, and it does apply to -- unconstrained arrays. Furthermore, it is essential to fold this -- in the packed case, since otherwise the value will be incorrect. - - -- Folding can also be done for Preelaborable_Initialization based on - -- whether the prefix type has preelaborable initialization, even though - -- the attribute is nonstatic. + -- Moreover, the exact same reasoning can be applied to Alignment. elsif Id = Attribute_Atomic_Always_Lock_Free or else Id = Attribute_Definite or else @@ -8747,7 +8748,8 @@ package body Sem_Attr is Id = Attribute_Preelaborable_Initialization or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array or else -Id = Attribute_Component_Size +Id = Attribute_Component_Size or else +Id = Attribute_Alignment then Static := False; Set_Is_Static_Expression (N, False); -- 2.43.2
[COMMITTED] ada: Recognize pragma Lock_Free as specific to GNAT
From: Piotr Trojanek Pramga Lock_Free must be recognized as implementation-defined. gcc/ada/ * sem_prag.adb (Analyze_Pragma): When processing pragma Lock_Free, check if restriction No_Implementation_Pragmas is enabled. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_prag.adb | 1 + 1 file changed, 1 insertion(+) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ff02ae9a7af..9e0e41c3dad 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -19950,6 +19950,7 @@ package body Sem_Prag is Val : Boolean; begin +GNAT_Pragma; Check_No_Identifiers; Check_At_Most_N_Arguments (1); -- 2.43.2
[COMMITTED] ada: Rewrite Append_Entity_Name; skip irrelevant names
From: Bob Duff This patch rewrites Append_Entity_Name, both for maintainability and to improve user messages. The main issue was that the recursion stopped when the enclosing scope is the wrapper created in case of postconditions with 'Old. This caused different results depending on the enabling/disabling of assertions. Instead of stopping, we now skip things that the user shouldn't see; there is useful information in more-outer scope names. Simplify the code. We had a nested procedure, which called itself recursively, and also was mutually recursive with the outer procedure. Avoid testing Is_Internal_Name of the Chars, which seems too fragile. 'R' is used for subprogram instances, but for example "SR" is used for TSS_Stream_Read, so removing 'R' works only by accident. Instead, base the test for subprogram instances on normal Einfo queries. The new version of Append_Entity_Name produces different (and better) results in many cases, but this fact is not apparent in most test cases, because they don't raise unhandled exceptions or do other things that involve printing the entity name. The comment: -- Otherwise nothing to output (happens in unnamed block statements) is removed; there are many cases other than block statements that reached that part of the code. gcc/ada/ * sem_util.ads (Append_Entity_Name): Fix comment to reflect new semantics. The comment said, "The qualification stops at an enclosing scope has no source name (block or loop)." There seems to be no reason for stopping; instead, we should SKIP things with no source name. And the "loop" part was wrong. * sem_util.adb (Append_Entity_Name): Do not stop the recursion; skip to next-outer scope instead. Misc cleanup/simplification. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 128 +-- gcc/ada/sem_util.ads | 7 +-- 2 files changed, 54 insertions(+), 81 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6350524874c..b30cbcd57e9 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -645,96 +645,70 @@ package body Sem_Util is -- Append_Entity_Name -- - procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is - Temp : Bounded_String; - - procedure Inner (E : Entity_Id); - -- Inner recursive routine, keep outer routine nonrecursive to ease - -- debugging when we get strange results from this routine. - - --- - -- Inner -- - --- - - procedure Inner (E : Entity_Id) is - Scop : Node_Id; - - begin - -- If entity has an internal name, skip by it, and print its scope. - -- Note that we strip a final R from the name before the test; this - -- is needed for some cases of instantiations. - - declare -E_Name : Bounded_String; - - begin -Append (E_Name, Chars (E)); - -if E_Name.Chars (E_Name.Length) = 'R' then - E_Name.Length := E_Name.Length - 1; -end if; - -if Is_Internal_Name (E_Name) then - Inner (Scope (E)); - return; -end if; - end; - - Scop := Scope (E); - - -- Just print entity name if its scope is at the outer level - - if Scop = Standard_Standard then + procedure Append_Entity_Name + (Buf : in out Bounded_String; E : Entity_Id) + is + Scop : constant Node_Id := Scope (E); + -- We recursively print the scope to Buf, and then print the simple + -- name, along with some special cases (see below). So for A.B.C.D, + -- recursively print A.B.C, then print D. + begin + -- If E is not a source entity, then skip the simple name and just + -- recursively print its scope. However, subprogram instances have + -- Comes_From_Source = False, but we do want to print the simple name + -- of the instance. + + if not Comes_From_Source (E) then + if Is_Generic_Instance (E) + and then Ekind (E) in E_Function | E_Procedure + then null; + else +Append_Entity_Name (Buf, Scope (E)); +return; + end if; + end if; - -- If scope comes from source, write scope and entity - - elsif Comes_From_Source (Scop) then -Append_Entity_Name (Temp, Scop); -Append (Temp, '.'); - - -- If in wrapper package skip past it - - elsif Present (Scop) and then Is_Wrapper_Package (Scop) then -Append_Entity_Name (Temp, Scope (Scop)); -Append (Temp, '.'); + -- Just print entity name if its scope is at the outer level - -- Otherwise nothing to output (happens in unnamed block statements) + if No (Scop) or Scop = Standard_Standard then + null; - else -
[COMMITTED] ada: Simplify uses of readdir_gnat with object overlay
From: Piotr Trojanek Code cleanup; behavior is unaffected. gcc/ada/ * libgnat/a-direct.adb (Start_Search_Internal): Combine subtype and object declaration. * libgnat/g-dirope.adb (Read): Replace convoluted unchecked conversion with an overlay. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-direct.adb | 4 +--- gcc/ada/libgnat/g-dirope.adb | 18 -- 2 files changed, 5 insertions(+), 17 deletions(-) diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb index 9e399c1003e..32e020c48c3 100644 --- a/gcc/ada/libgnat/a-direct.adb +++ b/gcc/ada/libgnat/a-direct.adb @@ -1367,9 +1367,7 @@ package body Ada.Directories is -- the Filter add it to our search vector. declare -subtype File_Name_String is String (1 .. File_Name_Len); - -File_Name : constant File_Name_String +File_Name : constant String (1 .. File_Name_Len) with Import, Address => File_Name_Addr; begin diff --git a/gcc/ada/libgnat/g-dirope.adb b/gcc/ada/libgnat/g-dirope.adb index 428d27d9e8d..d8ac0ec06f8 100644 --- a/gcc/ada/libgnat/g-dirope.adb +++ b/gcc/ada/libgnat/g-dirope.adb @@ -34,7 +34,6 @@ with Ada.Characters.Handling; with Ada.Strings.Fixed; with Ada.Unchecked_Deallocation; -with Ada.Unchecked_Conversion; with System; use System; with System.CRTL; use System.CRTL; @@ -677,24 +676,15 @@ package body GNAT.Directory_Operations is end if; declare - subtype Path_String is String (1 .. Filename_Len); - typePath_String_Access is not null access constant Path_String; - - function Address_To_Access is new - Ada.Unchecked_Conversion - (Source => Address, - Target => Path_String_Access); - - Path_Access : constant Path_String_Access := - Address_To_Access (Filename_Addr); - + Filename : constant String (1 .. Filename_Len) + with Import, Address => Filename_Addr; begin if Str'Length > Filename_Len then Last := Str'First + Filename_Len - 1; -Str (Str'First .. Last) := Path_Access.all; +Str (Str'First .. Last) := Filename; else Last := Str'Last; -Str := Path_Access (1 .. Str'Length); +Str := Filename (1 .. Str'Length); end if; end; end Read; -- 2.43.2
[COMMITTED] ada: Enable casing on composite via -X0 instead of -X
From: Steve Baird Move case statement pattern matching out of the curated language extension set and into the extended set. gcc/ada/ * sem_case.adb: Replace all tests of Core_Extensions_Allowed with corresponding tests of All_Extensions_Allowed. * sem_ch5.adb: Likewise. * doc/gnat_rm/gnat_language_extensions.rst: update documentation. * gnat_rm.texi: Regenerate. Tested on x86_64-pc-linux-gnu, committed on master. --- .../doc/gnat_rm/gnat_language_extensions.rst | 236 +++--- gcc/ada/gnat_rm.texi | 292 +- gcc/ada/sem_case.adb | 4 +- gcc/ada/sem_ch5.adb | 6 +- 4 files changed, 269 insertions(+), 269 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst index 42d64133989..c703e1c7e3f 100644 --- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -137,124 +137,6 @@ An exception message can also be added: Link to the original RFC: https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-conditional-when-constructs.rst -Case pattern matching -- - -The selector for a case statement (but not yet for a case expression) may be of a composite type, subject to -some restrictions (described below). Aggregate syntax is used for choices -of such a case statement; however, in cases where a "normal" aggregate would -require a discrete value, a discrete subtype may be used instead; box -notation can also be used to match all values. - -Consider this example: - -.. code-block:: ada - - type Rec is record - F1, F2 : Integer; - end record; - - procedure Caser_1 (X : Rec) is - begin - case X is -when (F1 => Positive, F2 => Positive) => - Do_This; -when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) => - Do_That; -when others => -Do_The_Other_Thing; - end case; - end Caser_1; - -If ``Caser_1`` is called and both components of X are positive, then -``Do_This`` will be called; otherwise, if either component is nonnegative -then ``Do_That`` will be called; otherwise, ``Do_The_Other_Thing`` will be -called. - -In addition, pattern bindings are supported. This is a mechanism -for binding a name to a component of a matching value for use within -an alternative of a case statement. For a component association -that occurs within a case choice, the expression may be followed by -``is ``. In the special case of a "box" component association, -the identifier may instead be provided within the box. Either of these -indicates that the given identifier denotes (a constant view of) the matching -subcomponent of the case selector. - -.. attention:: Binding is not yet supported for arrays or subcomponents - thereof. - -Consider this example (which uses type ``Rec`` from the previous example): - -.. code-block:: ada - - procedure Caser_2 (X : Rec) is - begin - case X is -when (F1 => Positive is Abc, F2 => Positive) => - Do_This (Abc) -when (F1 => Natural is N1, F2 => ) | - (F1 => , F2 => Natural is N1) => - Do_That (Param_1 => N1, Param_2 => N2); -when others => - Do_The_Other_Thing; - end case; - end Caser_2; - -This example is the same as the previous one with respect to determining -whether ``Do_This``, ``Do_That``, or ``Do_The_Other_Thing`` will be called. But -for this version, ``Do_This`` takes a parameter and ``Do_That`` takes two -parameters. If ``Do_This`` is called, the actual parameter in the call will be -``X.F1``. - -If ``Do_That`` is called, the situation is more complex because there are two -choices for that alternative. If ``Do_That`` is called because the first choice -matched (i.e., because ``X.F1`` is nonnegative and either ``X.F1`` or ``X.F2`` -is zero or negative), then the actual parameters of the call will be (in order) -``X.F1`` and ``X.F2``. If ``Do_That`` is called because the second choice -matched (and the first one did not), then the actual parameters will be -reversed. - -Within the choice list for single alternative, each choice must define the same -set of bindings and the component subtypes for for a given identifer must all -statically match. Currently, the case of a binding for a nondiscrete component -is not implemented. - -If the set of values that match the choice(s) of an earlier alternative -overlaps the corresponding set of a later alternative, then the first set shall -be a proper subset of the second (and the later alternative will not be -executed if the earlier alternative "matches"). All possible values of the -composite type shall be covered. The composite type of the selector shall be an -array or record type that is neither limited nor class-wide. Currently, a "when -others =>" case choice is required; it is intended that
[COMMITTED] ada: Fix internal error with Put_Image aspect on access-to-class-wide type
From: Eric Botcazou This occurs with an instantiation of Ada.Containers.Vectors in a nested package on an access-to-class-wide type declared with the Put_Image aspect because of too late a freezing for the internal renaming generated for the Put_Image procedure. The change freezes this renaming immediately in this particular case; this is similar to a trick used in Build_Array_Put_Image_Procedure. gcc/ada/ * sem_ch13.adb (New_Put_Image_Subprogram): In the nondeferred case coming from an aspect and for a type with delaying freezing, also freeze the subprogram immediately. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch13.adb | 5 + 1 file changed, 5 insertions(+) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 1f3f8277294..f3212f25dcc 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -15112,6 +15112,11 @@ package body Sem_Ch13 is then Append_Freeze_Action (Ent, Subp_Decl); + -- We may freeze Subp_Id immediately since Ent has just been frozen. + -- This will help to shield us from potential late freezing issues. + + Set_Is_Frozen (Subp_Id); + else Insert_Action (N, Subp_Decl); Set_Entity (N, Subp_Id); -- 2.43.2
[COMMITTED] ada: Small cleanup in the BIP machinery
From: Eric Botcazou This avoids creating Null nodes when they are not used in the end and makes the implementation of Add_Finalization_Master_Actual_To_Build_In_Place_Call more consistent with that of its sibling routines. No functional changes. gcc/ada/ * exp_ch6.adb (Add_Unconstrained_Actuals_To_Build_In_Place_Call): Rename Pool_Actual into Pool_Exp and use Empty as default value. (Add_Finalization_Master_Actual_To_Build_In_Place_Call): Change the names of the first two parameters and use a simpler code structure. (Make_Build_In_Place_Call_In_Allocator): Rename the local variable for the pool actual and set it to Empty if it is not used. (Make_Build_In_Place_Call_In_Object_Declaration): Rename the local variable for the master actual. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch6.adb | 192 ++-- 1 file changed, 98 insertions(+), 94 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 9e1844aa08e..0ab6c0080bf 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -157,22 +157,22 @@ package body Exp_Ch6 is Function_Id: Entity_Id; Alloc_Form : BIP_Allocation_Form := Unspecified; Alloc_Form_Exp : Node_Id := Empty; - Pool_Actual: Node_Id := Make_Null (No_Location)); + Pool_Exp : Node_Id := Empty); -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs -- them, add the actuals parameters BIP_Alloc_Form and BIP_Storage_Pool. -- If Alloc_Form_Exp is present, then pass it for the first parameter, -- otherwise pass a literal corresponding to the Alloc_Form parameter - -- (which must not be Unspecified in that case). Pool_Actual is the - -- parameter to pass to BIP_Storage_Pool. + -- (which must not be Unspecified in that case). If Pool_Exp is present, + -- then use it for BIP_Storage_Pool, otherwise pass "null". procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call : Node_Id; - Func_Id: Entity_Id; - Ptr_Typ: Entity_Id := Empty; - Master_Exp : Node_Id := Empty); + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty; + Master_Exp: Node_Id := Empty); -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs -- finalization actions, add an actual parameter which is a pointer to the - -- finalization master of the caller. If Master_Exp is not Empty, then that + -- finalization master of the caller. If Master_Exp is present, then that -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this -- will result in an automatic "null" value for the actual. @@ -424,13 +424,12 @@ package body Exp_Ch6 is Function_Id: Entity_Id; Alloc_Form : BIP_Allocation_Form := Unspecified; Alloc_Form_Exp : Node_Id := Empty; - Pool_Actual: Node_Id := Make_Null (No_Location)) + Pool_Exp : Node_Id := Empty) is Loc : constant Source_Ptr := Sloc (Function_Call); Alloc_Form_Actual : Node_Id; Alloc_Form_Formal : Node_Id; - Pool_Formal : Node_Id; begin -- Nothing to do when the size of the object is known, and the caller is @@ -472,10 +471,16 @@ package body Exp_Ch6 is -- those targets do not support pools. if RTE_Available (RE_Root_Storage_Pool_Ptr) then - Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); - Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal)); - Add_Extra_Actual_To_Call - (Function_Call, Pool_Formal, Pool_Actual); + declare +Pool_Actual : constant Node_Id := + (if Present (Pool_Exp) then Pool_Exp else Make_Null (Loc)); +Pool_Formal : constant Node_Id := + Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); + + begin +Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal)); +Add_Extra_Actual_To_Call (Function_Call, Pool_Formal, Pool_Actual); + end; end if; end Add_Unconstrained_Actuals_To_Build_In_Place_Call; @@ -484,92 +489,88 @@ package body Exp_Ch6 is --- procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call : Node_Id; - Func_Id: Entity_Id; - Ptr_Typ: Entity_Id := Empty; - Master_Exp : Node_Id := Empty) + (Function_Call : Node_Id; + Function_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty; + Master_Exp: Node_Id := Empty) is + Loc : constant Source_Ptr := Sloc (Function_Call); + + Actual: Node_Id; + Formal: Node_Id; + Desig_Typ : Entity_Id; + begin -
[COMMITTED] ada: Compiler crash on nonstatic container aggregates for Doubly_Linked_Lists
From: Gary Dismukes The compiler was crashing on container aggregates for the List type coming from an instantiation of Ada.Containers.Doubly_Linked_Lists when the aggregate has more than one iterated_element_association with nonstatic range bounds. As part of addressing this, it was noticed that there were also somewhat related problems with container aggregates associated with the Ada.Containers.Bounded_Doubly_Linked_Lists generic (and likely others like it) and mishandling of certain cases of indexed aggregates, and those are also addressed by this set of changes. In the case of container aggregates with at least one association with a nonstatic range, the total length of the aggregate is determined by expansion actions of Aggregate_Size. gcc/ada/ * exp_aggr.adb (Expand_Container_Aggregate): Move determination of whether the aggregate is an indexed aggregate earlier in the procedure. Test Is_Indexed_Aggregate as a criterion for generating a call to the container type's New_Indexed function, add proper computation of bounds to pass in to the function, and remove later code for generating such a call. Add and improve comments. (Aggregate_Size): Remove special treatment of case where there is exactly one component association, and instead loop over all component associations to determine whether any of them have a nonstatic length. If there is at least one such nonstatic association, return -1. (Build_Siz_Exp): Accumulate a sum of the sizes of each of the component associations in Siz_Exp (which will only be used if there any associations that are of Nkind N_Iterated_Component_Association with a nonstatic range). (Expand_Range_Component): Fix typos in the procedure's spec comment and block comment. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 247 ++- 1 file changed, 149 insertions(+), 98 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 950f310b58c..c82bd07aedc 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6662,6 +6662,8 @@ package body Exp_Aggr is end if; end Add_Range_Size; + -- Start of processing for Aggregate_Size + begin -- Aggregate is either all positional or all named @@ -6669,23 +6671,39 @@ package body Exp_Aggr is if Present (Component_Associations (N)) then Comp := First (Component_Associations (N)); --- If there is a single component association it can be --- an iterated component with dynamic bounds or an element --- iterator over an iterable object. If it is an array --- we can use the attribute Length to get its size; --- for a predefined container the function Length plays --- the same role. There is no available mechanism for --- user-defined containers. For now we treat all of these --- as dynamic. - -if List_Length (Component_Associations (N)) = 1 - and then Nkind (Comp) in N_Iterated_Component_Association | - N_Iterated_Element_Association -then - return Build_Siz_Exp (Comp); -end if; --- Otherwise all associations must specify static sizes. +-- If one or more of the associations is one of the iterated +-- forms, and is either an association with nonstatic bounds +-- or is an iterator over an iterable object, then treat the +-- whole container aggregate as having a nonstatic number of +-- elements. + +declare + Has_Nonstatic_Length : Boolean := False; + +begin + while Present (Comp) loop + if Nkind (Comp) in N_Iterated_Component_Association | + N_Iterated_Element_Association +and then Build_Siz_Exp (Comp) = -1 + then + Has_Nonstatic_Length := True; + end if; + + Next (Comp); + end loop; + + if Has_Nonstatic_Length then + return -1; + end if; +end; + +-- Otherwise, the aggregate must have associations where all +-- choices and bounds are statically known, and we compute +-- the number of elements statically by adding up the number +-- of elements in each association. + +Comp := First (Component_Associations (N)); while Present (Comp) loop Choice := First (Choice_List (Comp)); @@ -6731,7 +6749,9 @@ package body Exp_Aggr is --- function Build_Siz_Exp (Comp : Node_Id) return Int is -
[COMMITTED] ada: Refactor GNAT.Directory_Operations.Read to minimise runtime checks
From: Piotr Trojanek Array assignments are likely more efficient than element-by-element copying; in particular, they avoid constraints checks in every iteration of a loop (when the runtime is compiled with checks enabled). A cleanup and improvement opportunity spotted while working on improved detection of uninitialised local scalar objects. gcc/ada/ * libgnat/g-dirope.adb (Read): Use null-excluding, access-to-constant type; replace element-by-element copy with array assignments. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/g-dirope.adb | 16 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/gcc/ada/libgnat/g-dirope.adb b/gcc/ada/libgnat/g-dirope.adb index c23aa68b700..428d27d9e8d 100644 --- a/gcc/ada/libgnat/g-dirope.adb +++ b/gcc/ada/libgnat/g-dirope.adb @@ -676,13 +676,9 @@ package body GNAT.Directory_Operations is return; end if; - Last := -(if Str'Length > Filename_Len then Str'First + Filename_Len - 1 - else Str'Last); - declare subtype Path_String is String (1 .. Filename_Len); - typePath_String_Access is access Path_String; + typePath_String_Access is not null access constant Path_String; function Address_To_Access is new Ada.Unchecked_Conversion @@ -693,9 +689,13 @@ package body GNAT.Directory_Operations is Address_To_Access (Filename_Addr); begin - for J in Str'First .. Last loop -Str (J) := Path_Access (J - Str'First + 1); - end loop; + if Str'Length > Filename_Len then +Last := Str'First + Filename_Len - 1; +Str (Str'First .. Last) := Path_Access.all; + else +Last := Str'Last; +Str := Path_Access (1 .. Str'Length); + end if; end; end Read; -- 2.43.2
[COMMITTED] ada: Remove redundant guard against empty list of declarations
From: Piotr Trojanek Code cleanup. gcc/ada/ * inline.adb (Has_Single_Return): Remove redundant check for empty list, because First works also for empty list. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/inline.adb | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 169a22c0ba5..a628a59e145 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -4809,8 +4809,7 @@ package body Inline is else return - Present (Declarations (N)) - and then Present (First (Declarations (N))) + Present (First (Declarations (N))) and then Nkind (First (Declarations (N))) = N_Object_Declaration and then Entity (Expression (Return_Statement)) = Defining_Identifier (First (Declarations (N))); -- 2.43.2
[COMMITTED] ada: Remove obsolete field Postconditions_Proc
From: Eric Botcazou It is now totally unused by the front-end and dependent tools. gcc/ada/ * einfo.ads (Postconditions_Proc): Delete. * gen_il-fields.ads (Opt_Field_Enum): Remove Postconditions_Proc. * gen_il-gen-gen_entities.adb (E_Function): Likewise. (E_Procedure): Likewise. (E_Entry): Likewise. (E_Entry_Family): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/einfo.ads | 3 --- gcc/ada/gen_il-fields.ads | 1 - gcc/ada/gen_il-gen-gen_entities.adb | 4 3 files changed, 8 deletions(-) diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e3bfdb3507d..3c290ef9a93 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4016,9 +4016,6 @@ package Einfo is -- ensure that the finalization masters of all pending access types are -- fully initialized when the full view is frozen. ---Postconditions_Proc --- Obsolete field which can be removed once CodePeer is fixed ??? - --Predicate_Function (synthesized) -- Defined in all types. Set for types for which (Has_Predicates is True) -- and for which a predicate procedure has been built that tests that the diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index ac1e0c953f0..0a5bddf5816 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -851,7 +851,6 @@ package Gen_IL.Fields is Part_Of_References, Partial_View_Has_Unknown_Discr, Pending_Access_Types, - Postconditions_Proc, Predicate_Expression, Prev_Entity, Prival, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index cde016c3d1e..dd5db9746fd 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -1019,7 +1019,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Mechanism, Mechanism_Type), Sm (Next_Inlined_Subprogram, Node_Id), Sm (Original_Protected_Subprogram, Node_Id), -Sm (Postconditions_Proc, Node_Id), Sm (Predicate_Expression, Node_Id), Sm (Protected_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), @@ -1069,7 +1068,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (LSP_Subprogram, Node_Id), Sm (Next_Inlined_Subprogram, Node_Id), Sm (Original_Protected_Subprogram, Node_Id), -Sm (Postconditions_Proc, Node_Id), Sm (Protected_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), Sm (Receiving_Entry, Node_Id), @@ -1113,7 +,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Elaboration_Checks_OK_Id, Flag), Sm (Is_Elaboration_Warnings_OK_Id, Flag), Sm (Last_Entity, Node_Id), -Sm (Postconditions_Proc, Node_Id), Sm (Protected_Body_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), Sm (Scope_Depth_Value, Unat), @@ -1140,7 +1137,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Elaboration_Warnings_OK_Id, Flag), Sm (Last_Entity, Node_Id), Sm (Needs_No_Actuals, Flag), -Sm (Postconditions_Proc, Node_Id), Sm (Protected_Body_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), Sm (Renamed_Or_Alias, Node_Id), -- 2.43.2
[COMMITTED] Update copyright years.
Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-finpri.adb | 2 +- gcc/ada/libgnat/s-finpri.ads | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb index 7dc08a97f4b..05bf2a69ddc 100644 --- a/gcc/ada/libgnat/s-finpri.adb +++ b/gcc/ada/libgnat/s-finpri.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- ---Copyright (C) 2023, Free Software Foundation, Inc.-- +-- Copyright (C) 2023-2024, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads index ab79ea2c664..7a474436920 100644 --- a/gcc/ada/libgnat/s-finpri.ads +++ b/gcc/ada/libgnat/s-finpri.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- ---Copyright (C) 2023, Free Software Foundation, Inc.-- +-- Copyright (C) 2023-2024, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- 2.43.2
[COMMITTED] ada: Fix LTO type mismatches in GNAT.Sockets.Thin
From: Eric Botcazou The default implementation of GNAT.Sockets.Thin is mainly used on Linux and the socklen_t type used in various routines of the BSD sockets C API is a typedef for unsigned int there, so importing it as Interface.C.int will be flagged as a type mismatch during LTO compilation. gcc/ada/ * libgnat/g-socthi.ads (C_Bind): Turn into inline function. (C_Getpeername): Likewise. (C_Getsockname): Likewise. (C_Getsockopt): Likewise. (C_Setsockopt): Likewise. (Nonreentrant_Gethostbyaddr): Likewise. * libgnat/g-socthi.adb (Syscall_Accept): Adjust profile. (Syscall_Connect): Likewise. (Syscall_Recvfrom): Likewise. (Syscall_Sendto): Likewise. (C_Bind): New function. (C_Accept): Adjust to above change for profiles. (C_Connect): Likewise. (C_Getpeername): New function. (C_Getsockname): Likewise. (C_Getsockopt): Likewise. (C_Recvfrom): Adjust to above change for profiles. (C_Setsockopt): New function. (Nonreentrant_Gethostbyaddr): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/g-socthi.adb | 176 --- gcc/ada/libgnat/g-socthi.ads | 12 +-- 2 files changed, 170 insertions(+), 18 deletions(-) diff --git a/gcc/ada/libgnat/g-socthi.adb b/gcc/ada/libgnat/g-socthi.adb index dce2717cda3..f8ddcc7fca6 100644 --- a/gcc/ada/libgnat/g-socthi.adb +++ b/gcc/ada/libgnat/g-socthi.adb @@ -62,13 +62,13 @@ package body GNAT.Sockets.Thin is function Syscall_Accept (S : C.int; Addr: System.Address; - Addrlen : not null access C.int) return C.int; + Addrlen : not null access C.unsigned) return C.int; pragma Import (C, Syscall_Accept, "accept"); function Syscall_Connect (S : C.int; Name: System.Address; - Namelen : C.int) return C.int; + Namelen : C.unsigned) return C.int; pragma Import (C, Syscall_Connect, "connect"); function Syscall_Recv @@ -84,7 +84,7 @@ package body GNAT.Sockets.Thin is Len : C.size_t; Flags : C.int; From: System.Address; - Fromlen : not null access C.int) return System.CRTL.ssize_t; + Fromlen : not null access C.unsigned) return System.CRTL.ssize_t; pragma Import (C, Syscall_Recvfrom, "recvfrom"); function Syscall_Recvmsg @@ -105,7 +105,7 @@ package body GNAT.Sockets.Thin is Len : C.size_t; Flags : C.int; To: System.Address; - Tolen : C.int) return System.CRTL.ssize_t; + Tolen : C.unsigned) return System.CRTL.ssize_t; pragma Import (C, Syscall_Sendto, "sendto"); function Syscall_Socket @@ -125,6 +125,25 @@ package body GNAT.Sockets.Thin is function Non_Blocking_Socket (S : C.int) return Boolean; procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); + + -- C_Bind -- + + + function C_Bind + (S : C.int; + Name: System.Address; + Namelen : C.int) return C.int + is + function Bind +(S : C.int; + Name: System.Address; + Namelen : C.unsigned) return C.int + with Import, Convention => C, External_Name => "bind"; + + begin + return Bind (S, Name, C.unsigned (Namelen)); + end C_Bind; + -- -- C_Accept -- -- @@ -134,15 +153,18 @@ package body GNAT.Sockets.Thin is Addr: System.Address; Addrlen : not null access C.int) return C.int is - R : C.int; - Val : aliased C.int := 1; + R : C.int; + U_Addrlen : aliased C.unsigned; + Val : aliased C.int := 1; Discard : C.int; pragma Warnings (Off, Discard); begin + U_Addrlen := C.unsigned (Addrlen.all); + loop - R := Syscall_Accept (S, Addr, Addrlen); + R := Syscall_Accept (S, Addr, U_Addrlen'Unchecked_Access); exit when SOSC.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) @@ -150,6 +172,8 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; + Addrlen.all := C.int (U_Addrlen); + if not SOSC.Thread_Blocking_IO and then R /= Failure then @@ -177,7 +201,7 @@ package body GNAT.Sockets.Thin is Res : C.int; begin - Res := Syscall_Connect (S, Name, Namelen); + Res := Syscall_Connect (S, Name, C.unsigned (Namelen)); if SOSC.Thread_Blocking_IO or else Res /= Failure @@ -215,7 +239,7 @@ package body GNAT.Sockets.Thin is end loop; end; - Res := Syscall_Connect (S, Name, Namelen); + Res := Syscall_Connect (S, Name, C.unsigned (Namelen)); if Res = Failure and then Errno = SOSC.EISCONN @@ -226,6 +250,85 @@ package body GNAT.Sockets.Thin is end if; end C_Connect; + --- + -- C_Getpeer
[COMMITTED] ada: Fix grammar in comment
From: Piotr Trojanek Code cleanup. gcc/ada/ * exp_aggr.ads (Static_Array_Aggregate): Fix typo in comment. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.ads | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads index 8db0a020663..0b92e98370a 100644 --- a/gcc/ada/exp_aggr.ads +++ b/gcc/ada/exp_aggr.ads @@ -61,7 +61,7 @@ package Exp_Aggr is -- N is an array aggregate that may have a component association with -- an others clause and a range. If bounds are static and the expressions -- are compile-time known constants, rewrite N as a purely positional - -- aggregate, to be use to initialize variables and components of the type + -- aggregate, to be used to initialize variables and components of the type -- without generating elaboration code. end Exp_Aggr; -- 2.43.2
[COMMITTED] ada: Aspects on multiple component declarations
From: Bob Duff
This patch fixes a bug where aspect specifications were ignored
on all but the last of multiple component declarations.
For example, in a record type with components "X, Y: T with Volatile;"
only Y was marked Volatile; X was not. Both should be marked Volatile.
The fix is in Par.Ch3.P_Component_Items, where P_Aspect_Specifications
needs to be called each time through the loop.
In addition, various minor cleanups.
gcc/ada/
* par-ch3.adb (P_Component_Items): Move P_Aspect_Specifications
into the loop, so aspects can be attached to multiple component
declarations.
(P_Type_Declaration, P_Subtype_Declaration)
(P_Known_Discriminant_Part_Opt): Remove default for Semicolon in
calls to P_Aspect_Specifications.
* gen_il-gen-gen_nodes.adb (N_Discriminant_Specification): Add
Aspect_Specifications field to N_Discriminant_Specification, which
was missing.
* aspects.adb (Has_Aspect_Specifications_Flag): Make it True for
N_Discriminant_Specification.
* par-ch13.adb: Remove default for Semicolon in calls to
P_Aspect_Specifications.
(Get_Aspect_Specifications): Misc cleanup.
(P_Aspect_Specifications): Remove comment. It's not clear what
"the flag" is referring to, but anyway the first part of the
comment is obvious, and the second part is apparently obsolete.
Misc cleanup.
* par.adb (P_Aspect_Specifications, Get_Aspect_Specifications):
Remove default for Semicolon; calls are more readable that way.
Improve comments.
* par-ch12.adb: Remove default for Semicolon in calls to
P_Aspect_Specifications.
* par-ch6.adb: Likewise.
* par-ch7.adb: Likewise.
* par-ch9.adb: Likewise.
* par-endh.adb: Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.adb | 3 ++-
gcc/ada/gen_il-gen-gen_nodes.adb | 1 +
gcc/ada/par-ch12.adb | 12 ++--
gcc/ada/par-ch13.adb | 30 +++---
gcc/ada/par-ch3.adb | 12 ++--
gcc/ada/par-ch6.adb | 12 ++--
gcc/ada/par-ch7.adb | 2 +-
gcc/ada/par-ch9.adb | 4 ++--
gcc/ada/par-endh.adb | 6 +++---
gcc/ada/par.adb | 22 +++---
10 files changed, 45 insertions(+), 59 deletions(-)
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index 0d4988ac540..696ee672acd 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -450,6 +450,7 @@ package body Aspects is
Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
(N_Abstract_Subprogram_Declaration=> True,
N_Component_Declaration => True,
+ N_Discriminant_Specification => True,
N_Entry_Body => True,
N_Entry_Declaration => True,
N_Exception_Declaration => True,
@@ -471,8 +472,8 @@ package body Aspects is
N_Package_Body_Stub => True,
N_Package_Declaration=> True,
N_Package_Instantiation => True,
- N_Package_Specification => True,
N_Package_Renaming_Declaration => True,
+ N_Package_Specification => True,
N_Parameter_Specification=> True,
N_Private_Extension_Declaration => True,
N_Private_Type_Declaration => True,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index d7cc39bc048..fb00993a95e 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -1375,6 +1375,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Null_Exclusion_Present, Flag, Default_False),
Sy (Discriminant_Type, Node_Id),
Sy (Expression, Node_Id, Default_Empty),
+Sy (Aspect_Specifications, List_Id, Default_No_List),
Sm (More_Ids, Flag),
Sm (Prev_Ids, Flag)));
diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb
index 8eb06b682bf..56ab07c0cb3 100644
--- a/gcc/ada/par-ch12.adb
+++ b/gcc/ada/par-ch12.adb
@@ -223,7 +223,7 @@ package body Ch12 is
Error_Msg_SP ("child unit allowed only at library level");
end if;
- P_Aspect_Specifications (Gen_Decl);
+ P_Aspect_Specifications (Gen_Decl, Semicolon => True);
end if;
Set_Generic_Formal_Declarations (Gen_Decl, Decls);
@@ -482,7 +482,7 @@ package body Ch12 is
No_Constraint;
Set_Default_Expression (Decl_Node, Init_Expr_Opt);
- P_Aspect_Specifications (Decl_Node);
+ P_Aspect_Specifications (Decl_Node, Semicolon => True);
if Ident > 1 then
Set_Prev_Ids (Decl_Node, True);
@@ -570,7 +570,7 @@ package body Ch12 is
end if;
[COMMITTED] ada: Fix calculation of tasks in null arrays
From: Piotr Trojanek Fix handling of null arrays when calculating the secondary stack size for the binder. gcc/ada/ * sem_util.adb (Number_Of_Elements_In_Array): Fix counting of elements in null arrays; remove redundant parenthesis; avoid run-time conversion of 1 to universal integer. 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 bee078e6df5..5f44b4c26fe 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -25404,7 +25404,8 @@ package body Sem_Util is return 0; else Num := - Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1)); + Num * Int'Max +(0, UI_To_Int (Expr_Value (High) - Expr_Value (Low) + Uint_1)); end if; Next_Index (Indx); -- 2.43.2
[COMMITTED] ada: Remove redundant guard against empty list of actions
From: Piotr Trojanek Code cleanup. gcc/ada/ * exp_ch4.adb (Useful): Remove redundant check for empty list, because iteration with First works also for empty list; rename local variable from L to Action. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 25 +++-- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 5fa47c9b6e7..505c4b3151a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12930,8 +12930,7 @@ package body Exp_Ch4 is -- to Opnd /= Shortcut_Value. function Useful (Actions : List_Id) return Boolean; - -- Return True if Actions is not empty and contains useful nodes to - -- process. + -- Return True if Actions contains useful nodes to process -- Make_Test_Expr -- @@ -12951,22 +12950,20 @@ package body Exp_Ch4 is function Useful (Actions : List_Id) return Boolean is - L : Node_Id; + Action : Node_Id; begin - if Present (Actions) then -L := First (Actions); + Action := First (Actions); --- For now "useful" means not N_Variable_Reference_Marker. --- Consider stripping other nodes in the future. + -- For now "useful" means not N_Variable_Reference_Marker. Consider + -- stripping other nodes in the future. -while Present (L) loop - if Nkind (L) /= N_Variable_Reference_Marker then - return True; - end if; + while Present (Action) loop +if Nkind (Action) /= N_Variable_Reference_Marker then + return True; +end if; - Next (L); -end loop; - end if; +Next (Action); + end loop; return False; end Useful; -- 2.43.2
[COMMITTED] ada: SPARK rule changed on functions with side effects
From: Yannick Moy SPARK RM definition of function with side effects now makes them implicitly volatile functions. gcc/ada/ * sem_util.adb (Is_Volatile_Function): Return True on functions with side effects. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 5 + 1 file changed, 5 insertions(+) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 18c9de05cf9..3af029fd9a3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -21226,6 +21226,11 @@ package body Sem_Util is then return True; + -- A function with side-effects is volatile + + elsif Is_Function_With_Side_Effects (Func_Id) then + return True; + -- Otherwise the function is treated as volatile if it is subject to -- enabled pragma Volatile_Function. -- 2.43.2
[COMMITTED] ada: Prevent calculation of negative stack counts
From: Piotr Trojanek Negative numbers of stack counts have no meaning. gcc/ada/ * lib.ads, lib.adb (Primary_Stack_Count, Sec_Stack_Count, Increment_Primary_Stack_Count, Increment_Sec_Stack_Count, Unit_Record): Stack counts are never negative. * ali.ads (Unit_Record): Likewise. * bindgen.adb (Num_Primary_Stacks, Num_Sec_Stacks): Likewise. * exp_ch3.adb (Count_Default_Sized_Task_Stacks): Likewise. * sem_util.ads, sem_util.adb (Number_Of_Elements_In_Array): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/ali.ads | 4 ++-- gcc/ada/bindgen.adb | 4 ++-- gcc/ada/exp_ch3.adb | 2 +- gcc/ada/lib.adb | 12 ++-- gcc/ada/lib.ads | 12 ++-- gcc/ada/sem_util.adb | 4 ++-- gcc/ada/sem_util.ads | 2 +- 7 files changed, 20 insertions(+), 20 deletions(-) diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 23c744433a3..67b8fcd1b80 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -482,11 +482,11 @@ package ALI is -- Indicates whether a package body or a spec has a library-level -- finalization routine. - Primary_Stack_Count : Int; + Primary_Stack_Count : Nat; -- Indicates the number of task objects declared in this unit that have -- default sized primary stacks. - Sec_Stack_Count : Int; + Sec_Stack_Count : Nat; -- Indicates the number of task objects declared in this unit that have -- default sized secondary stacks. end record; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index bffd1344212..fc834e3a9b6 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -57,11 +57,11 @@ package body Bindgen is Num_Elab_Calls : Nat := 0; -- Number of generated calls to elaboration routines - Num_Primary_Stacks : Int := 0; + Num_Primary_Stacks : Nat := 0; -- Number of default-sized primary stacks the binder needs to allocate for -- task objects declared in the program. - Num_Sec_Stacks : Int := 0; + Num_Sec_Stacks : Nat := 0; -- Number of default-sized primary stacks the binder needs to allocate for -- task objects declared in the program. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e9fab87365c..f934dbfddaa 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6738,7 +6738,7 @@ package body Exp_Ch3 is -- Then multiply the result by the size of the array declare - Quantity : constant Int := Number_Of_Elements_In_Array (Typ); + Quantity : constant Nat := Number_Of_Elements_In_Array (Typ); -- Number_Of_Elements_In_Array is non-trival, consequently -- its result is captured as an optimization. diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index ebd6bc99040..c465828c562 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -173,12 +173,12 @@ package body Lib is return Units.Table (U).OA_Setting; end OA_Setting; - function Primary_Stack_Count (U : Unit_Number_Type) return Int is + function Primary_Stack_Count (U : Unit_Number_Type) return Nat is begin return Units.Table (U).Primary_Stack_Count; end Primary_Stack_Count; - function Sec_Stack_Count (U : Unit_Number_Type) return Int is + function Sec_Stack_Count (U : Unit_Number_Type) return Nat is begin return Units.Table (U).Sec_Stack_Count; end Sec_Stack_Count; @@ -1034,8 +1034,8 @@ package body Lib is -- Increment_Primary_Stack_Count -- --- - procedure Increment_Primary_Stack_Count (Increment : Int) is - PSC : Int renames Units.Table (Current_Sem_Unit).Primary_Stack_Count; + procedure Increment_Primary_Stack_Count (Increment : Nat) is + PSC : Nat renames Units.Table (Current_Sem_Unit).Primary_Stack_Count; begin PSC := PSC + Increment; end Increment_Primary_Stack_Count; @@ -1044,8 +1044,8 @@ package body Lib is -- Increment_Sec_Stack_Count -- --- - procedure Increment_Sec_Stack_Count (Increment : Int) is - SSC : Int renames Units.Table (Current_Sem_Unit).Sec_Stack_Count; + procedure Increment_Sec_Stack_Count (Increment : Nat) is + SSC : Nat renames Units.Table (Current_Sem_Unit).Sec_Stack_Count; begin SSC := SSC + Increment; end Increment_Sec_Stack_Count; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index ee06cde2727..93ff1b13531 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -463,8 +463,8 @@ package Lib is function No_Elab_Code_All (U : Unit_Number_Type) return Boolean; function OA_Setting (U : Unit_Number_Type) return Character; function Primary_Stack_Count - (U : Unit_Number_Type) return Int; - function Sec_Stack_Count (U : Unit_Number_Type) return Int; + (U : Unit_Number_Type) return Nat; + function Sec_Stack_
[COMMITTED] ada: Cleanup calculation of task stacks
From: Piotr Trojanek Code cleanup; semantics is unaffected. gcc/ada/ * exp_ch3.adb (Count_Default_Sized_Task_Stacks): Do not look for tasks inside record discriminants; remove avoid repeated call to Has_Task that happened for record components. (Expand_N_Object_Declaration): Use high-level routine to detect array types and subtypes; remove unused initial values. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 31 +-- 1 file changed, 13 insertions(+), 18 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4c0679f531b..e9fab87365c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6752,27 +6752,23 @@ package body Exp_Ch3 is | E_Record_Subtype | E_Record_Type => - Component := First_Component_Or_Discriminant (Typ); + Component := First_Component (Typ); -- Recursively descend each component of the composite type - -- looking for tasks, but only if the component is marked as - -- having a task. + -- looking for tasks. while Present (Component) loop - if Has_Task (Etype (Component)) then - declare -P : Int; -S : Int; + declare + P : Int; + S : Int; - begin -Count_Default_Sized_Task_Stacks - (Etype (Component), P, S); -Pri_Stacks := Pri_Stacks + P; -Sec_Stacks := Sec_Stacks + S; - end; - end if; + begin + Count_Default_Sized_Task_Stacks (Etype (Component), P, S); + Pri_Stacks := Pri_Stacks + P; + Sec_Stacks := Sec_Stacks + S; + end; - Next_Component_Or_Discriminant (Component); + Next_Component (Component); end loop; when E_Limited_Private_Subtype @@ -7457,11 +7453,10 @@ package body Exp_Ch3 is and then not Restriction_Active (No_Secondary_Stack) and then (Restriction_Active (No_Implicit_Heap_Allocations) or else Restriction_Active (No_Implicit_Task_Allocations)) -and then not (Ekind (Typ) in E_Array_Type | E_Array_Subtype - and then Has_Init_Expression (N)) +and then not (Is_Array_Type (Typ) and then Has_Init_Expression (N)) then declare -PS_Count, SS_Count : Int := 0; +PS_Count, SS_Count : Int; begin Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count); Increment_Primary_Stack_Count (PS_Count); -- 2.43.2
[COMMITTED] ada: Cleanup detection of per-object constraints in inlining for SPARK
From: Piotr Trojanek In GNATprove mode we didn't inline subprograms whose formal parameters was of a record type with constraints depending on discriminants. Now this is extended to formal parameters with per-object constraints, regardless if they come from references to discriminants or from attributes prefixed by the current type instance. gcc/ada/ * inline.adb (Has_Formal_With_Per_Object_Constrained_Component): Use flag Has_Per_Object_Constraint which is set by analysis; rename for consistency. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/inline.adb | 28 ++-- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index b7a6cc90cd2..169a22c0ba5 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1555,7 +1555,7 @@ package body Inline is -- a return type of a deep type: either an access type or a composite -- type containing an access type. - function Has_Formal_With_Discriminant_Dependent_Fields + function Has_Formal_With_Per_Object_Constrained_Component (Id : Entity_Id) return Boolean; -- Returns true if the subprogram has at least one formal parameter of -- an unconstrained record type with per-object constraints on component @@ -1701,23 +1701,23 @@ package body Inline is return False; end Has_Formal_Or_Result_Of_Deep_Type; - --- - -- Has_Formal_With_Discriminant_Dependent_Fields -- - --- + -- + -- Has_Formal_With_Per_Object_Constrained_Component -- + -- - function Has_Formal_With_Discriminant_Dependent_Fields + function Has_Formal_With_Per_Object_Constrained_Component (Id : Entity_Id) return Boolean is - function Has_Discriminant_Dependent_Component + function Has_Per_Object_Constrained_Component (Typ : Entity_Id) return Boolean; -- Determine whether unconstrained record type Typ has at least one -- component that depends on a discriminant. -- - -- Has_Discriminant_Dependent_Component -- + -- Has_Per_Object_Constrained_Component -- -- - function Has_Discriminant_Dependent_Component + function Has_Per_Object_Constrained_Component (Typ : Entity_Id) return Boolean is Comp : Entity_Id; @@ -1728,7 +1728,7 @@ package body Inline is Comp := First_Component (Typ); while Present (Comp) loop - if Has_Discriminant_Dependent_Constraint (Comp) then + if Has_Per_Object_Constraint (Comp) then return True; end if; @@ -1736,7 +1736,7 @@ package body Inline is end loop; return False; - end Has_Discriminant_Dependent_Component; + end Has_Per_Object_Constrained_Component; -- Local variables @@ -1745,7 +1745,7 @@ package body Inline is Formal_Typ : Entity_Id; -- Start of processing for - -- Has_Formal_With_Discriminant_Dependent_Fields + -- Has_Formal_With_Per_Object_Constrained_Component begin -- Inspect all parameters of the subprogram looking for a formal @@ -1758,7 +1758,7 @@ package body Inline is if Is_Record_Type (Formal_Typ) and then not Is_Constrained (Formal_Typ) - and then Has_Discriminant_Dependent_Component (Formal_Typ) + and then Has_Per_Object_Constrained_Component (Formal_Typ) then return True; end if; @@ -1767,7 +1767,7 @@ package body Inline is end loop; return False; - end Has_Formal_With_Discriminant_Dependent_Fields; + end Has_Formal_With_Per_Object_Constrained_Component; -- Has_Hide_Unhide_Annotation -- @@ -2063,7 +2063,7 @@ package body Inline is -- in record component accesses (in particular with records containing -- packed arrays). - elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then + elsif Has_Formal_With_Per_Object_Constrained_Component (Id) then return False; -- Do not inline subprograms with a formal parameter or return type of -- 2.43.2
[COMMITTED] ada: Accept constants of access types as globals of side-effect function
From: Piotr Trojanek Complete support for functions with side-effects. gcc/ada/ * sem_prag.adb (Analyze_Global_Item): Handle side-effect functions like procedures. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_prag.adb | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0eb4450dba3..fa2a4cbed39 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2860,7 +2860,9 @@ package body Sem_Prag is | E_Procedure | E_Generic_Procedure | E_Task_Type - or else Is_Single_Task_Object (Spec_Id)) + or else Is_Single_Task_Object (Spec_Id) + or else + Is_Function_With_Side_Effects (Spec_Id)) then null; else -- 2.43.2
[COMMITTED] ada: Bad internal naming when using pragma Compile_Time_Error
From: Justin Squirek This patch fixes an error in the compiler whereby the presence of a condition which tests the size of a type not known at compile time within an instance of pragma Compile_Time_Error causes incorrect internal names to be generated for said type during expansion. gcc/ada/ * sem_prag.adb (Defer_Compile_Time_Warning_Error_To_BE): Better handle itypes such that the tree copy required for the expansion of the pragma doesn't cause ordering problems with internal names. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_prag.adb | 18 +- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index fa2a4cbed39..a2996137648 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -33812,7 +33812,23 @@ package body Sem_Prag is -- as 0. if not In_Extended_Main_Code_Unit (N) then - Insert_Library_Level_Action (New_Copy_Tree (N)); + -- We've created an Itype for the string in this pragma and + -- may have made other Itypes. When we copy the entire tree + -- of this pragma, we'll make a second copy of them in its + -- unit, which will mess up the numbering of the remaining + -- internal names. + + declare +Saved_Current_Sem_Unit : constant Unit_Number_Type := + Current_Sem_Unit; +New_N : Node_Id; + + begin +Current_Sem_Unit := Main_Unit; +New_N := New_Copy_Tree (N); +Current_Sem_Unit := Saved_Current_Sem_Unit; +Insert_Library_Level_Action (New_N); + end; end if; end Defer_Compile_Time_Warning_Error_To_BE; -- 2.43.2
