* [COMMITTED 02/22] ada: Fix for Default_Component_Value with declare expressions
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
@ 2024-06-21 8:57 ` Marc Poulhiès
2024-06-21 8:57 ` [COMMITTED 03/22] ada: Fix assertion failure on predicate involving access parameter Marc Poulhiès
` (19 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:57 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
When the expression of aspect Default_Component_Value includes a declare
expression with current type instance, we attempted to recursively froze
that type, which itself caused an infinite recursion, because we didn't
properly manage the scope of declare expression.
This patch fixes both the detection of the current type instance and
analysis of the expression that caused recursive freezing.
gcc/ada/
* sem_attr.adb (In_Aspect_Specification): Use the standard
condition that works correctly with declare expressions.
* sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Replace
ordinary analysis with preanalysis of spec expressions.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 4 +++-
gcc/ada/sem_ch13.adb | 12 ++++++++++--
2 files changed, 13 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 72f5ab49175..d56c25a79cc 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1843,7 +1843,9 @@ package body Sem_Attr is
if Nkind (P) = N_Aspect_Specification then
return P_Type = Entity (P);
- elsif Nkind (P) in N_Declaration then
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (P) then
return False;
end if;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 4012932a6f2..a86f774018a 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1037,11 +1037,19 @@ package body Sem_Ch13 is
Parent_Type : Entity_Id;
+ Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
+
begin
-- Ensure Expr is analyzed so that e.g. all types are properly
- -- resolved for Find_Type_Reference.
+ -- resolved for Find_Type_Reference. We preanalyze this expression
+ -- as a spec expression (to avoid recursive freezing), while skipping
+ -- resolution (to not fold type self-references, e.g. T'Last).
- Analyze (Expr);
+ In_Spec_Expression := True;
+
+ Preanalyze (Expr);
+
+ In_Spec_Expression := Save_In_Spec_Expression;
-- A self-referential aspect is illegal if it forces freezing the
-- entity before the corresponding aspect has been analyzed.
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 03/22] ada: Fix assertion failure on predicate involving access parameter
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
2024-06-21 8:57 ` [COMMITTED 02/22] ada: Fix for Default_Component_Value with declare expressions Marc Poulhiès
@ 2024-06-21 8:57 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 04/22] ada: Predefined arithmetic operators incorrectly treated as directly visible Marc Poulhiès
` (18 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:57 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The assertion fails because the Original_Node of the expression has no Etype
since its an unanalyzed identifier.
gcc/ada/
* accessibility.adb (Accessibility_Level): Apply the processing to
Expr when its Original_Node is an unanalyzed identifier.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 13 ++++++++++++-
1 file changed, 12 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index da4d1d9ce2e..298103377a7 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -398,7 +398,7 @@ package body Accessibility is
-- Local variables
- E : Node_Id := Original_Node (Expr);
+ E : Node_Id;
Pre : Node_Id;
-- Start of processing for Accessibility_Level
@@ -409,6 +409,17 @@ package body Accessibility is
if Present (Param_Entity (Expr)) then
E := Param_Entity (Expr);
+
+ -- Use the original node unless it is an unanalyzed identifier, as we
+ -- don't want to reason on unanalyzed expressions from predicates.
+
+ elsif Nkind (Original_Node (Expr)) /= N_Identifier
+ or else Analyzed (Original_Node (Expr))
+ then
+ E := Original_Node (Expr);
+
+ else
+ E := Expr;
end if;
-- Extract the entity
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 04/22] ada: Predefined arithmetic operators incorrectly treated as directly visible
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
2024-06-21 8:57 ` [COMMITTED 02/22] ada: Fix for Default_Component_Value with declare expressions Marc Poulhiès
2024-06-21 8:57 ` [COMMITTED 03/22] ada: Fix assertion failure on predicate involving access parameter Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 05/22] ada: Fix gnatcheck violation reported after a recent cleanup Marc Poulhiès
` (17 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Steve Baird
From: Steve Baird <baird@adacore.com>
In some cases, a predefined operator (e.g., the "+" operator for an
integer type) is incorrectly treated as being directly visible when
it is not. This can lead to both accepting operator uses that should
be rejected and also to incorrectly rejecting legal constructs as ambiguous
(for example, an expression "Foo + 1" where Foo is an overloaded function and
the "+" operator is directly visible for the result type of only one of
the possible callees).
gcc/ada/
* sem_ch4.adb (Is_Effectively_Visible_Operator): A new function.
(Check_Arithmetic_Pair): In paths where Add_One_Interp was
previously called unconditionally, instead call only if
Is_Effectively_Visible_Operator returns True.
(Check_Boolean_Pair): Likewise.
(Find_Unary_Types): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch4.adb | 22 +++++++++++++++++++++-
1 file changed, 21 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 1175a34df21..dfeff02a011 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -270,6 +270,18 @@ package body Sem_Ch4 is
-- these aspects can be achieved without larger modifications to the
-- two-pass resolution algorithm.
+ function Is_Effectively_Visible_Operator
+ (N : Node_Id; Typ : Entity_Id) return Boolean
+ is (Is_Visible_Operator (N => N, Typ => Typ)
+ or else
+ -- test for a rewritten Foo."+" call
+ (N /= Original_Node (N)
+ and then Is_Effectively_Visible_Operator
+ (N => Original_Node (N), Typ => Typ))
+ or else not Comes_From_Source (N));
+ -- Return True iff either Is_Visible_Operator returns True or if
+ -- there is a reason it is ok for Is_Visible_Operator to return False.
+
function Possible_Type_For_Conditional_Expression
(T1, T2 : Entity_Id) return Entity_Id;
-- Given two types T1 and T2 that are _not_ compatible, return a type that
@@ -6641,6 +6653,8 @@ package body Sem_Ch4 is
and then (Covers (T1 => T1, T2 => T2)
or else
Covers (T1 => T2, T2 => T1))
+ and then Is_Effectively_Visible_Operator
+ (N, Specific_Type (T1, T2))
then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
end if;
@@ -6670,6 +6684,8 @@ package body Sem_Ch4 is
and then (Covers (T1 => T1, T2 => T2)
or else
Covers (T1 => T2, T2 => T1))
+ and then Is_Effectively_Visible_Operator
+ (N, Specific_Type (T1, T2))
then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
@@ -6713,6 +6729,8 @@ package body Sem_Ch4 is
and then (Covers (T1 => T1, T2 => T2)
or else
Covers (T1 => T2, T2 => T1))
+ and then Is_Effectively_Visible_Operator
+ (N, Specific_Type (T1, T2))
then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
end if;
@@ -7086,6 +7104,7 @@ package body Sem_Ch4 is
T := Any_Modular;
end if;
+ -- test Is_Effectively_Visible_Operator here ???
Add_One_Interp (N, Op_Id, T);
end if;
end Check_Boolean_Pair;
@@ -7615,7 +7634,8 @@ package body Sem_Ch4 is
then
null;
- else
+ elsif Is_Effectively_Visible_Operator (N, Base_Type (It.Typ))
+ then
Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
end if;
end if;
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 05/22] ada: Fix gnatcheck violation reported after a recent cleanup
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (2 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 04/22] ada: Predefined arithmetic operators incorrectly treated as directly visible Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 06/22] ada: Generic formal/actual matching -- misc cleanup Marc Poulhiès
` (16 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Piotr Trojanek
From: Piotr Trojanek <trojanek@adacore.com>
Code cleanup; semantics is unaffected.
gcc/ada/
* sem_ch3.adb (Add_Interface_Tag_Components): Simplify with No.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch3.adb | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index eebaedc216b..a1112d7b44a 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1618,7 +1618,7 @@ package body Sem_Ch3 is
Last_Tag := Empty;
- if not Present (Component_List (Ext)) then
+ if No (Component_List (Ext)) then
Set_Null_Present (Ext, False);
L := New_List;
Set_Component_List (Ext,
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 06/22] ada: Generic formal/actual matching -- misc cleanup
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (3 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 05/22] ada: Fix gnatcheck violation reported after a recent cleanup Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 07/22] ada: Fix incorrect handling of packed array with aliased composite components Marc Poulhiès
` (15 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Bob Duff
From: Bob Duff <duff@adacore.com>
The only substantive change is to remove Activation_Chain_Entity
from N_Generic_Package_Declaration. The comment in sinfo.ads suggesting
this change was written in 1993!
Various pieces of missing documentation are added to Sinfo and Einfo.
Also other minor cleanups.
gcc/ada/
* gen_il-gen-gen_nodes.adb
(N_Generic_Package_Declaration): Remove Activation_Chain_Entity.
* sinfo.ads: Comment improvements. Add missing doc.
Remove obsolete comment about Activation_Chain_Entity.
* einfo.ads: Comment improvements. Add missing doc.
* einfo-utils.adb (Base_Type): Add Assert (disabled for now).
(Next_Index): Minor cleanup.
* aspects.ads: Minor comment fix.
* exp_ch6.adb: Likewise.
* sem_ch3.adb: Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 2 +-
gcc/ada/einfo-utils.adb | 29 ++++++++++++++++++++---------
gcc/ada/einfo.ads | 29 +++++++++++++++--------------
gcc/ada/exp_ch6.adb | 4 ++--
gcc/ada/gen_il-gen-gen_nodes.adb | 3 +--
gcc/ada/sem_ch3.adb | 4 ++--
gcc/ada/sinfo.ads | 32 ++++++++++++++++++--------------
7 files changed, 59 insertions(+), 44 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 140fb7c8fe1..cf992a89038 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -1176,7 +1176,7 @@ package Aspects is
Class_Present : Boolean := False;
Or_Rep_Item : Boolean := False) return Node_Id;
-- Find the aspect specification of aspect A (or A'Class if Class_Present)
- -- associated with entity I.
+ -- associated with entity Id.
-- If found, then return the aspect specification.
-- If not found and Or_Rep_Item is true, then look for a representation
-- item (as opposed to an N_Aspect_Specification node) which specifies
diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 438868ac757..4c86ba1c3b1 100644
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -664,12 +664,22 @@ package body Einfo.Utils is
function Base_Type (Id : E) return E is
begin
- if Is_Base_Type (Id) then
- return Id;
- else
- pragma Assert (Is_Type (Id));
- return Etype (Id);
- end if;
+ return Result : E do
+ if Is_Base_Type (Id) then
+ Result := Id;
+ else
+ pragma Assert (Is_Type (Id));
+ Result := Etype (Id);
+ if False then
+ pragma Assert (Is_Base_Type (Result));
+ -- ???It seems like Base_Type should return a base type,
+ -- but this assertion is disabled because it is not always
+ -- true. Hence the need to say "Base_Type (Base_Type (...))"
+ -- in some cases; Base_Type is not idempotent as one might
+ -- expect.
+ end if;
+ end if;
+ end return;
end Base_Type;
----------------------
@@ -2018,10 +2028,11 @@ package body Einfo.Utils is
----------------
function Next_Index (Id : N) return Node_Id is
- begin
pragma Assert (Nkind (Id) in N_Is_Index);
- pragma Assert (No (Next (Id)) or else Nkind (Next (Id)) in N_Is_Index);
- return Next (Id);
+ Result : constant Node_Id := Next (Id);
+ pragma Assert (No (Result) or else Nkind (Result) in N_Is_Index);
+ begin
+ return Result;
end Next_Index;
------------------
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 8ee419b3e07..dd95ea051c1 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1334,7 +1334,7 @@ package Einfo is
-- First_Component (synthesized)
-- Applies to incomplete, private, protected, record and task types.
-- Returns the first component by following the chain of declared
--- entities for the type a component is found (one with an Ekind of
+-- entities for the type until a component is found (one with an Ekind of
-- E_Component). The discriminants are skipped. If the record is null,
-- then Empty is returned.
@@ -1342,6 +1342,10 @@ package Einfo is
-- Similar to First_Component, but discriminants are not skipped, so will
-- find the first discriminant if discriminants are present.
+-- First_Discriminant (synthesized)
+-- Defined for types with discriminants or unknown discriminants.
+-- Returns the first in the Next_Discriminant chain; see Sem_Aux.
+
-- First_Entity
-- Defined in all entities that act as scopes to which a list of
-- associated entities is attached, and also in all [sub]types. Some
@@ -1375,12 +1379,11 @@ package Einfo is
-- First_Index
-- Defined in array types and subtypes. By introducing implicit subtypes
-- for the index constraints, we have the same structure for constrained
--- and unconstrained arrays, subtype marks and discrete ranges are
--- both represented by a subtype. This function returns the tree node
--- corresponding to an occurrence of the first index (NOT the entity for
--- the type). Subsequent indices are obtained using Next_Index. Note that
--- this field is defined for the case of string literal subtypes, but is
--- always Empty.
+-- and unconstrained arrays, subtype marks and discrete ranges are both
+-- represented by a subtype. This function returns the N_Is_Index tree
+-- node corresponding to the first index (not an entity). Subsequent
+-- indices are obtained using Next_Index. Note that this field is defined
+-- for the case of string literal subtypes, but is always Empty.
-- First_Literal
-- Defined in all enumeration types, including character and boolean
@@ -3749,13 +3752,11 @@ package Einfo is
-- all the extra formals (see description of Extra_Formal field)
-- Next_Index (synthesized)
--- Applies to array types and subtypes and to string types and
--- subtypes. Yields the next index. The first index is obtained by
--- using the First_Index attribute, and then subsequent indexes are
--- obtained by applying Next_Index to the previous index. Empty is
--- returned to indicate that there are no more indexes. Note that
--- unlike most attributes in this package, Next_Index applies to
--- nodes for the indexes, not to entities.
+-- Applies to the N_Is_Index node returned by First_Index/Next_Index;
+-- returns the next N_Is_Index node in the chain. Empty is returned to
+-- indicate that there are no more indexes. Note that unlike most
+-- attributes in this package, Next_Index applies to nodes for the
+-- indexes, not to entities.
-- Next_Inlined_Subprogram
-- Defined in subprograms. Used to chain inlined subprograms used in
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index da19c031c3d..6d3d05fcf20 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -2939,8 +2939,8 @@ package body Exp_Ch6 is
-- If the aspect is inherited, convert the pointer to the
-- parent type that specifies the contract.
-- If the original access_to_subprogram has defaults for
- -- in_parameters, the call may include named associations, so
- -- we create one for the pointer as well.
+ -- in-mode parameters, the call may include named associations,
+ -- so we create one for the pointer as well.
if Is_Derived_Type (Ptr_Type)
and then Ptr_Type /= Etype (Last_Formal (Wrapper))
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 580723666c5..b1ca6cf6c86 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -915,8 +915,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Cc (N_Generic_Package_Declaration, N_Generic_Declaration,
(Sy (Specification, Node_Id),
Sy (Generic_Formal_Declarations, List_Id),
- Sy (Aspect_Specifications, List_Id, Default_No_List),
- Sm (Activation_Chain_Entity, Node_Id)));
+ Sy (Aspect_Specifications, List_Id, Default_No_List)));
Cc (N_Generic_Subprogram_Declaration, N_Generic_Declaration,
(Sy (Specification, Node_Id),
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index a1112d7b44a..fa13bd23ac7 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1250,8 +1250,8 @@ package body Sem_Ch3 is
-- to incomplete types declared in some enclosing scope, not to limited
-- views from other packages.
- -- Prior to Ada 2012, access to functions parameters must be of mode
- -- 'in'.
+ -- Prior to Ada 2012, all parameters of an access-to-function type must
+ -- be of mode 'in'.
if Present (Formals) then
Formal := First_Formal (Desig_Type);
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 599f4f63cce..3696ca4f7b4 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -2304,6 +2304,10 @@ package Sinfo is
-- scope all use this field to reference the corresponding scope entity.
-- See Einfo for further details.
+ -- Selector_Name
+ -- Present in N_Expanded_Name N_Selected_Component,
+ -- N_Generic_Association, and N_Parameter_Association nodes.
+
-- Shift_Count_OK
-- A flag present in shift nodes to indicate that the shift count is
-- known to be in range, i.e. is in the range from zero to word length
@@ -7013,7 +7017,7 @@ package Sinfo is
-- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION
-- [ASPECT_SPECIFICATIONS];
- -- Note: Generic_Formal_Declarations can include pragmas
+ -- Note: Generic_Formal_Declarations can include pragmas and use clauses
-- N_Generic_Subprogram_Declaration
-- Sloc points to GENERIC
@@ -7030,11 +7034,7 @@ package Sinfo is
-- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION
-- [ASPECT_SPECIFICATIONS];
- -- Note: when we do generics right, the Activation_Chain_Entity entry
- -- for this node can be removed (since the expander won't see generic
- -- units any more)???.
-
- -- Note: Generic_Formal_Declarations can include pragmas
+ -- Note: Generic_Formal_Declarations can include pragmas and use clauses
-- N_Generic_Package_Declaration
-- Sloc points to GENERIC
@@ -7042,7 +7042,6 @@ package Sinfo is
-- Corresponding_Body
-- Generic_Formal_Declarations from generic formal part
-- Parent_Spec
- -- Activation_Chain_Entity
-------------------------------
-- 12.1 Generic Formal Part --
@@ -7143,16 +7142,19 @@ package Sinfo is
-- Note: unlike the procedure call case, a generic association node
-- is generated for every association, even if no formal parameter
- -- selector name is present. In this case the parser will leave the
- -- Selector_Name field set to Empty, to be filled in later by the
- -- semantic pass.
+ -- selector name is present, in which case Selector_Name is Empty.
-- In Ada 2005, a formal may be associated with a box, if the
-- association is part of the list of actuals for a formal package.
- -- If the association is given by OTHERS => <>, the association is
+ -- If the association is given by OTHERS => <>, the association is
-- an N_Others_Choice (not an N_Generic_Association whose Selector_Name
-- is an N_Others_Choice).
+ -- In source nodes, either Explicit_Generic_Actual_Parameter is present,
+ -- or Box_Present is True. However, Sem_Ch12 generates "dummy" nodes
+ -- with Explicit_Generic_Actual_Parameter = Empty and Box_Present =
+ -- False.
+
-- N_Generic_Association
-- Sloc points to first token of generic association
-- Selector_Name (set to Empty if no formal
@@ -7382,13 +7384,15 @@ package Sinfo is
-- Default_Name (set to Empty if no subprogram default)
-- Box_Present
-- Expression (set to Empty if no expression present)
+ -- If the default is "is null", then Null_Present is set
+ -- on the Specification of this node.
-- Note: If no subprogram default is present, then Name is set
-- to Empty, and Box_Present is False.
- -- Note: The Expression field is only used for the GNAT extension
- -- that allows a FORMAL_CONCRETE_SUBPROGRAM_DECLARATION to specify
- -- an expression default for generic formal functions.
+ -- Note: The Expression field is for the GNAT extension that allows a
+ -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION to specify an expression
+ -- default for generic formal functions.
--------------------------------------------------
-- 12.6 Formal Abstract Subprogram Declaration --
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 07/22] ada: Fix incorrect handling of packed array with aliased composite components
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (4 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 06/22] ada: Generic formal/actual matching -- misc cleanup Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 08/22] ada: Fix internal error on case expression used as index of array component Marc Poulhiès
` (14 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The problem is that the handling of the interaction between packing and
aliased/atomic/independent components of an array type is tied to that of
the interaction between a component clause and aliased/atomic/independent
components, although the semantics are different: packing is a best effort
thing, whereas a component clause must be honored or else an error be given.
This decouples the two handlings, but retrofits the separate processing of
independent components done in both cases into the common code and changes
the error message from "minimum allowed is" to "minimum allowed value is"
for the sake of consistency with the aliased/atomic processing.
gcc/ada/
* freeze.adb (Freeze_Array_Type): Decouple the handling of the
interaction between packing and aliased/atomic components from
that of the interaction between a component clause and aliased/
atomic components, and retrofit the processing of the interaction
between the two characteristics and independent components into
the common processing.
gcc/testsuite/ChangeLog:
* gnat.dg/atomic10.adb: Adjust.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/freeze.adb | 190 ++++++++++++++---------------
gcc/testsuite/gnat.dg/atomic10.adb | 4 +-
2 files changed, 93 insertions(+), 101 deletions(-)
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 1867880b314..29733a17a56 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -3634,7 +3634,9 @@ package body Freeze is
procedure Freeze_Array_Type (Arr : Entity_Id) is
FS : constant Entity_Id := First_Subtype (Arr);
Ctyp : constant Entity_Id := Component_Type (Arr);
- Clause : Entity_Id;
+
+ Clause : Node_Id;
+ -- Set to Component_Size clause or Atomic pragma, if any
Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration type with a
@@ -3710,76 +3712,57 @@ package body Freeze is
end;
end if;
- -- Check for Aliased or Atomic_Components or Full Access with
- -- unsuitable packing or explicit component size clause given.
-
- if (Has_Aliased_Components (Arr)
- or else Has_Atomic_Components (Arr)
- or else Is_Full_Access (Ctyp))
- and then
- (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
- then
- Alias_Atomic_Check : declare
+ -- Check for Aliased or Atomic or Full Access or Independent
+ -- components with an unsuitable component size clause given.
+ -- The main purpose is to give an error when bit packing would
+ -- be required to honor the component size, because bit packing
+ -- is incompatible with these aspects; when bit packing is not
+ -- required, the final validation of the component size may be
+ -- left to the back end.
- procedure Complain_CS (T : String);
- -- Outputs error messages for incorrect CS clause or pragma
- -- Pack for aliased or full access components (T is either
- -- "aliased" or "atomic" or "volatile full access");
+ if Has_Component_Size_Clause (Arr) then
+ CS_Check : declare
+ procedure Complain_CS (T : String; Min : Boolean := False);
+ -- Output an error message for an unsuitable component size
+ -- clause for independent components (T is either "aliased"
+ -- or "atomic" or "volatile full access" or "independent").
-----------------
-- Complain_CS --
-----------------
- procedure Complain_CS (T : String) is
+ procedure Complain_CS (T : String; Min : Boolean := False) is
begin
- if Has_Component_Size_Clause (Arr) then
- Clause :=
- Get_Attribute_Definition_Clause
- (FS, Attribute_Component_Size);
+ Clause :=
+ Get_Attribute_Definition_Clause
+ (FS, Attribute_Component_Size);
- Error_Msg_N
- ("incorrect component size for "
- & T & " components", Clause);
- Error_Msg_Uint_1 := Esize (Ctyp);
- Error_Msg_N
- ("\only allowed value is^", Clause);
+ Error_Msg_N
+ ("incorrect component size for " & T & " components",
+ Clause);
+ if Known_Static_Esize (Ctyp) then
+ Error_Msg_Uint_1 := Esize (Ctyp);
+ if Min then
+ Error_Msg_N ("\minimum allowed value is^", Clause);
+ else
+ Error_Msg_N ("\only allowed value is^", Clause);
+ end if;
else
Error_Msg_N
- ("?cannot pack " & T & " components (RM 13.2(7))",
- Get_Rep_Pragma (FS, Name_Pack));
- Set_Is_Packed (Arr, False);
+ ("\must be multiple of storage unit", Clause);
end if;
end Complain_CS;
- -- Start of processing for Alias_Atomic_Check
+ -- Start of processing for CS_Check
begin
- -- If object size of component type isn't known, we cannot
- -- be sure so we defer to the back end.
+ -- OK if the component size and object size are equal, or
+ -- if the component size is a multiple of the storage unit.
- if not Known_Static_Esize (Ctyp) then
- null;
-
- -- Case where component size has no effect. First check for
- -- object size of component type multiple of the storage
- -- unit size.
-
- elsif Esize (Ctyp) mod System_Storage_Unit = 0
-
- -- OK in both packing case and component size case if RM
- -- size is known and static and same as the object size.
-
- and then
- ((Known_Static_RM_Size (Ctyp)
- and then Esize (Ctyp) = RM_Size (Ctyp))
-
- -- Or if we have an explicit component size clause and
- -- the component size and object size are equal.
-
- or else
- (Has_Component_Size_Clause (Arr)
- and then Component_Size (Arr) = Esize (Ctyp)))
+ if (if Known_Static_Esize (Ctyp)
+ then Component_Size (Arr) = Esize (Ctyp)
+ else Component_Size (Arr) mod System_Storage_Unit = 0)
then
null;
@@ -3793,67 +3776,76 @@ package body Freeze is
elsif Is_Volatile_Full_Access (Ctyp) then
Complain_CS ("volatile full access");
+
+ -- For Independent a larger size is permitted
+
+ elsif (Has_Independent_Components (Arr)
+ or else Is_Independent (Ctyp))
+ and then (not Known_Static_Esize (Ctyp)
+ or else Component_Size (Arr) < Esize (Ctyp))
+ then
+ Complain_CS ("independent", Min => True);
end if;
- end Alias_Atomic_Check;
- end if;
+ end CS_Check;
- -- Check for Independent_Components/Independent with unsuitable
- -- packing or explicit component size clause given.
+ -- Check for Aliased or Atomic or Full Access or Independent
+ -- components with an unsuitable aspect/pragma Pack given.
+ -- The main purpose is to prevent bit packing from occurring,
+ -- because bit packing is incompatible with these aspects; when
+ -- bit packing cannot occur, the final handling of the packing
+ -- may be left to the back end.
- if (Has_Independent_Components (Arr) or else Is_Independent (Ctyp))
- and then
- (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
- then
- begin
- -- If object size of component type isn't known, we cannot
- -- be sure so we defer to the back end.
+ elsif Is_Packed (Arr) and then Known_Static_RM_Size (Ctyp) then
+ Pack_Check : declare
- if not Known_Static_Esize (Ctyp) then
- null;
+ procedure Complain_Pack (T : String);
+ -- Output a warning message for an unsuitable aspect/pragma
+ -- Pack for independent components (T is either "aliased" or
+ -- "atomic" or "volatile full access" or "independent") and
+ -- reset the Is_Packed flag on the array type.
- -- Case where component size has no effect. First check for
- -- object size of component type multiple of the storage
- -- unit size.
+ -------------------
+ -- Complain_Pack --
+ -------------------
- elsif Esize (Ctyp) mod System_Storage_Unit = 0
+ procedure Complain_Pack (T : String) is
+ begin
+ Error_Msg_N
+ ("?cannot pack " & T & " components (RM 13.2(7))",
+ Get_Rep_Pragma (FS, Name_Pack));
- -- OK in both packing case and component size case if RM
- -- size is known and multiple of the storage unit size.
+ Set_Is_Packed (Arr, False);
+ end Complain_Pack;
- and then
- ((Known_Static_RM_Size (Ctyp)
- and then RM_Size (Ctyp) mod System_Storage_Unit = 0)
+ -- Start of processing for Pack_Check
- -- Or if we have an explicit component size clause and
- -- the component size is larger than the object size.
+ begin
+ -- OK if the component size and object size are equal, or
+ -- if the component size is a multiple of the storage unit.
- or else
- (Has_Component_Size_Clause (Arr)
- and then Component_Size (Arr) >= Esize (Ctyp)))
+ if (if Known_Static_Esize (Ctyp)
+ then RM_Size (Ctyp) = Esize (Ctyp)
+ else RM_Size (Ctyp) mod System_Storage_Unit = 0)
then
null;
- else
- if Has_Component_Size_Clause (Arr) then
- Clause :=
- Get_Attribute_Definition_Clause
- (FS, Attribute_Component_Size);
+ elsif Has_Aliased_Components (Arr) then
+ Complain_Pack ("aliased");
- Error_Msg_N
- ("incorrect component size for "
- & "independent components", Clause);
- Error_Msg_Uint_1 := Esize (Ctyp);
- Error_Msg_N
- ("\minimum allowed is^", Clause);
+ elsif Has_Atomic_Components (Arr)
+ or else Is_Atomic (Ctyp)
+ then
+ Complain_Pack ("atomic");
- else
- Error_Msg_N
- ("?cannot pack independent components (RM 13.2(7))",
- Get_Rep_Pragma (FS, Name_Pack));
- Set_Is_Packed (Arr, False);
- end if;
+ elsif Is_Volatile_Full_Access (Ctyp) then
+ Complain_Pack ("volatile full access");
+
+ elsif Has_Independent_Components (Arr)
+ or else Is_Independent (Ctyp)
+ then
+ Complain_Pack ("independent");
end if;
- end;
+ end Pack_Check;
end if;
-- If packing was requested or if the component size was
diff --git a/gcc/testsuite/gnat.dg/atomic10.adb b/gcc/testsuite/gnat.dg/atomic10.adb
index 5f99ca66266..69685732f21 100644
--- a/gcc/testsuite/gnat.dg/atomic10.adb
+++ b/gcc/testsuite/gnat.dg/atomic10.adb
@@ -14,8 +14,8 @@ procedure Atomic10 is
subtype Index_Type is Positive range 1 .. Max;
- type Array_Type is array (Index_Type) of aliased Atomic_Unsigned; -- { dg-error "cannot be guaranteed" }
- for Array_Type'Component_Size use Comp_Size;
+ type Array_Type is array (Index_Type) of aliased Atomic_Unsigned;
+ for Array_Type'Component_Size use Comp_Size; -- { dg-error "incorrect|only" }
Slots : Array_Type;
begin
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 08/22] ada: Fix internal error on case expression used as index of array component
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (5 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 07/22] ada: Fix incorrect handling of packed array with aliased composite components Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 09/22] ada: Fix missing index check with declare expression Marc Poulhiès
` (13 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This occurs when the bounds of the array component depend on a discriminant
and the component reference is not nested, that is to say the component is
not (referenced as) a subcomponent of a larger record.
In this case, Analyze_Selected_Component does not build the actual subtype
for the component, but it turns out to be required for constructs generated
during the analysis of the case expression.
The change causes this actual subtype to be built, and also renames a local
variable used to hold the prefix of the selected component.
gcc/ada/
* sem_ch4.adb (Analyze_Selected_Component): Rename Name into Pref
and use Sel local variable consistently.
(Is_Simple_Indexed_Component): New predicate.
Call Is_Simple_Indexed_Component to determine whether to build an
actual subtype for the component.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch4.adb | 108 ++++++++++++++++++++++++++++++--------------
1 file changed, 73 insertions(+), 35 deletions(-)
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index dfeff02a011..4e1d1bc7ed7 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -4927,7 +4927,7 @@ package body Sem_Ch4 is
-- the selector must denote a visible entry.
procedure Analyze_Selected_Component (N : Node_Id) is
- Name : constant Node_Id := Prefix (N);
+ Pref : constant Node_Id := Prefix (N);
Sel : constant Node_Id := Selector_Name (N);
Act_Decl : Node_Id;
Comp : Entity_Id := Empty;
@@ -4962,8 +4962,11 @@ package body Sem_Ch4 is
-- indexed component rather than a function call.
function Has_Dereference (Nod : Node_Id) return Boolean;
- -- Check whether prefix includes a dereference, explicit or implicit,
- -- at any recursive level.
+ -- Check whether Nod includes a dereference, explicit or implicit, at
+ -- any recursive level.
+
+ function Is_Simple_Indexed_Component (Nod : Node_Id) return Boolean;
+ -- Check whether Nod is a simple indexed component in the context
function Try_By_Protected_Procedure_Prefixed_View return Boolean;
-- Return True if N is an access attribute whose prefix is a prefixed
@@ -5107,6 +5110,40 @@ package body Sem_Ch4 is
end if;
end Has_Dereference;
+ ---------------------------------
+ -- Is_Simple_Indexed_Component --
+ ---------------------------------
+
+ function Is_Simple_Indexed_Component (Nod : Node_Id) return Boolean is
+ Expr : Node_Id;
+
+ begin
+ -- Nod must be an indexed component
+
+ if Nkind (Nod) /= N_Indexed_Component then
+ return False;
+ end if;
+
+ -- The context must not be a nested selected component
+
+ if Nkind (Pref) = N_Selected_Component then
+ return False;
+ end if;
+
+ -- The expressions must not be case expressions
+
+ Expr := First (Expressions (Nod));
+ while Present (Expr) loop
+ if Nkind (Expr) = N_Case_Expression then
+ return False;
+ end if;
+
+ Next (Expr);
+ end loop;
+
+ return True;
+ end Is_Simple_Indexed_Component;
+
----------------------------------------------
-- Try_By_Protected_Procedure_Prefixed_View --
----------------------------------------------
@@ -5292,17 +5329,17 @@ package body Sem_Ch4 is
begin
Set_Etype (N, Any_Type);
- if Is_Overloaded (Name) then
+ if Is_Overloaded (Pref) then
Analyze_Overloaded_Selected_Component (N);
return;
- elsif Etype (Name) = Any_Type then
+ elsif Etype (Pref) = Any_Type then
Set_Entity (Sel, Any_Id);
Set_Etype (Sel, Any_Type);
return;
else
- Prefix_Type := Etype (Name);
+ Prefix_Type := Etype (Pref);
end if;
if Is_Access_Type (Prefix_Type) then
@@ -5345,8 +5382,8 @@ package body Sem_Ch4 is
-- component prefixes because of the prefixed dispatching call case.
-- Note that implicit dereferences are checked for this just above.
- elsif Nkind (Name) = N_Explicit_Dereference
- and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name)))
+ elsif Nkind (Pref) = N_Explicit_Dereference
+ and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Pref)))
and then Comes_From_Source (N)
then
if Try_Object_Operation (N) then
@@ -5397,7 +5434,7 @@ package body Sem_Ch4 is
Is_Concurrent_Type (Prefix_Type)
and then Is_Internal_Name (Chars (Prefix_Type))
and then not Is_Derived_Type (Prefix_Type)
- and then Is_Entity_Name (Name);
+ and then Is_Entity_Name (Pref);
-- Avoid initializing Comp if that initialization is not needed
-- (and, more importantly, if the call to First_Entity could fail).
@@ -5425,8 +5462,8 @@ package body Sem_Ch4 is
-- subsequent semantic checks might examine the original node.
Set_Entity (Sel, Comp);
- Rewrite (Selector_Name (N), New_Occurrence_Of (Comp, Sloc (N)));
- Set_Original_Discriminant (Selector_Name (N), Comp);
+ Rewrite (Sel, New_Occurrence_Of (Comp, Sloc (N)));
+ Set_Original_Discriminant (Sel, Comp);
Set_Etype (N, Etype (Comp));
Check_Implicit_Dereference (N, Etype (Comp));
@@ -5477,7 +5514,7 @@ package body Sem_Ch4 is
-- to duplicate this prefix and duplication is only allowed
-- on fully resolved expressions.
- Resolve (Name);
+ Resolve (Pref);
-- Ada 2005 (AI-50217): Check wrong use of incomplete types or
-- subtypes in a package specification.
@@ -5490,38 +5527,39 @@ package body Sem_Ch4 is
-- N : Natural := X.all.Comp; -- ERROR, limited view
-- end Pkg; -- Comp is not visible
- if Nkind (Name) = N_Explicit_Dereference
- and then From_Limited_With (Etype (Prefix (Name)))
- and then not Is_Potentially_Use_Visible (Etype (Name))
+ if Nkind (Pref) = N_Explicit_Dereference
+ and then From_Limited_With (Etype (Prefix (Pref)))
+ and then not Is_Potentially_Use_Visible (Etype (Pref))
and then Nkind (Parent (Cunit_Entity (Current_Sem_Unit))) =
N_Package_Specification
then
Error_Msg_NE
- ("premature usage of incomplete}", Prefix (Name),
- Etype (Prefix (Name)));
+ ("premature usage of incomplete}", Prefix (Pref),
+ Etype (Prefix (Pref)));
end if;
- -- We never need an actual subtype for the case of a selection
- -- for a indexed component of a non-packed array, since in
- -- this case gigi generates all the checks and can find the
- -- necessary bounds information.
+ -- We generally do not need an actual subtype for the case of
+ -- a selection for an indexed component of a non-packed array,
+ -- since, in this case, gigi can find all the necessary bound
+ -- information. However, when the prefix is itself a selected
+ -- component, for example a.b.c (i), gigi may regard a.b.c as
+ -- a dynamic-sized temporary, so we generate an actual subtype
+ -- for this case. Moreover, if the expressions are complex,
+ -- the actual subtype may be needed for constructs generated
+ -- by their analysis.
-- We also do not need an actual subtype for the case of a
-- first, last, length, or range attribute applied to a
-- non-packed array, since gigi can again get the bounds in
-- these cases (gigi cannot handle the packed case, since it
-- has the bounds of the packed array type, not the original
- -- bounds of the type). However, if the prefix is itself a
- -- selected component, as in a.b.c (i), gigi may regard a.b.c
- -- as a dynamic-sized temporary, so we do generate an actual
- -- subtype for this case.
+ -- bounds of the type).
Parent_N := Parent (N);
if not Is_Packed (Etype (Comp))
and then
- ((Nkind (Parent_N) = N_Indexed_Component
- and then Nkind (Name) /= N_Selected_Component)
+ (Is_Simple_Indexed_Component (Parent_N)
or else
(Nkind (Parent_N) = N_Attribute_Reference
and then
@@ -5603,8 +5641,8 @@ package body Sem_Ch4 is
-- Force the generation of a mutably tagged type conversion
-- when we encounter a special class-wide equivalent type.
- if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (Name)) then
- Make_Mutably_Tagged_Conversion (Name, Force => True);
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (Pref)) then
+ Make_Mutably_Tagged_Conversion (Pref, Force => True);
end if;
Check_Implicit_Dereference (N, Etype (N));
@@ -5616,7 +5654,7 @@ package body Sem_Ch4 is
-- which can appear in expanded code in a tag check.
if Ekind (Type_To_Use) = E_Record_Type_With_Private
- and then Chars (Selector_Name (N)) /= Name_uTag
+ and then Chars (Sel) /= Name_uTag
then
exit when Comp = Last_Entity (Type_To_Use);
end if;
@@ -5786,7 +5824,7 @@ package body Sem_Ch4 is
elsif Ekind (Comp) in E_Discriminant | E_Entry_Family
or else (In_Scope
and then not Is_Protected_Type (Prefix_Type)
- and then Is_Entity_Name (Name))
+ and then Is_Entity_Name (Pref))
then
Set_Entity_With_Checks (Sel, Comp);
Generate_Reference (Comp, Sel);
@@ -5856,8 +5894,8 @@ package body Sem_Ch4 is
-- and the selector is one of the task operations.
if In_Scope
- and then not Is_Entity_Name (Name)
- and then not Has_Dereference (Name)
+ and then not Is_Entity_Name (Pref)
+ and then not Has_Dereference (Pref)
then
if Is_Task_Type (Prefix_Type)
and then Present (Entity (Sel))
@@ -5974,7 +6012,7 @@ package body Sem_Ch4 is
if Present (Comp) then
if Is_Single_Concurrent_Object then
- Error_Msg_Node_2 := Entity (Name);
+ Error_Msg_Node_2 := Entity (Pref);
Error_Msg_NE ("invisible selector& for &", N, Sel);
else
@@ -6006,7 +6044,7 @@ package body Sem_Ch4 is
if Etype (N) = Any_Type then
if Is_Single_Concurrent_Object then
- Error_Msg_Node_2 := Entity (Name);
+ Error_Msg_Node_2 := Entity (Pref);
Error_Msg_NE ("no selector& for&", N, Sel);
Check_Misspelled_Selector (Type_To_Use, Sel);
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 09/22] ada: Fix missing index check with declare expression
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (6 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 08/22] ada: Fix internal error on case expression used as index of array component Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 10/22] ada: Cannot override inherited function with controlling result Marc Poulhiès
` (12 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The Do_Range_Check flag is properly set on the Expression of the EWA node
built for the declare expression, so this instructs Generate_Index_Checks
to look into this Expression.
gcc/ada/
* checks.adb (Generate_Index_Checks): Add specific treatment for
index expressions that are N_Expression_With_Actions nodes.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/checks.adb | 36 ++++++++++++++++++++++++++----------
1 file changed, 26 insertions(+), 10 deletions(-)
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index bada3dffcbf..c8a0696be67 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -7248,7 +7248,8 @@ package body Checks is
Loc : constant Source_Ptr := Sloc (N);
A : constant Node_Id := Prefix (N);
A_Ent : constant Entity_Id := Entity_Of_Prefix;
- Sub : Node_Id;
+
+ Expr : Node_Id;
-- Start of processing for Generate_Index_Checks
@@ -7294,13 +7295,13 @@ package body Checks is
-- us to omit the check have already been taken into account in the
-- setting of the Do_Range_Check flag earlier on.
- Sub := First (Expressions (N));
+ Expr := First (Expressions (N));
-- Handle string literals
if Ekind (Etype (A)) = E_String_Literal_Subtype then
- if Do_Range_Check (Sub) then
- Set_Do_Range_Check (Sub, False);
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
-- For string literals we obtain the bounds of the string from the
-- associated subtype.
@@ -7310,8 +7311,8 @@ package body Checks is
Condition =>
Make_Not_In (Loc,
Left_Opnd =>
- Convert_To (Base_Type (Etype (Sub)),
- Duplicate_Subexpr_Move_Checks (Sub)),
+ Convert_To (Base_Type (Etype (Expr)),
+ Duplicate_Subexpr_Move_Checks (Expr)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etype (A), Loc),
@@ -7330,11 +7331,19 @@ package body Checks is
Ind : Pos;
Num : List_Id;
Range_N : Node_Id;
+ Stmt : Node_Id;
+ Sub : Node_Id;
begin
A_Idx := First_Index (Etype (A));
Ind := 1;
- while Present (Sub) loop
+ while Present (Expr) loop
+ if Nkind (Expr) = N_Expression_With_Actions then
+ Sub := Expression (Expr);
+ else
+ Sub := Expr;
+ end if;
+
if Do_Range_Check (Sub) then
Set_Do_Range_Check (Sub, False);
@@ -7396,7 +7405,7 @@ package body Checks is
Expressions => Num);
end if;
- Insert_Action (N,
+ Stmt :=
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Not_In (Loc,
@@ -7404,14 +7413,21 @@ package body Checks is
Convert_To (Base_Type (Etype (Sub)),
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd => Range_N),
- Reason => CE_Index_Check_Failed));
+ Reason => CE_Index_Check_Failed);
+
+ if Nkind (Expr) = N_Expression_With_Actions then
+ Append_To (Actions (Expr), Stmt);
+ Analyze (Stmt);
+ else
+ Insert_Action (Expr, Stmt);
+ end if;
Checks_Generated.Elements (Ind) := True;
end if;
Next_Index (A_Idx);
Ind := Ind + 1;
- Next (Sub);
+ Next (Expr);
end loop;
end;
end if;
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 10/22] ada: Cannot override inherited function with controlling result
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (7 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 09/22] ada: Fix missing index check with declare expression Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 11/22] ada: Revert conditional installation of signal handlers on VxWorks Marc Poulhiès
` (11 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Javier Miranda
From: Javier Miranda <miranda@adacore.com>
When a package has the declaration of a derived tagged
type T with private null extension that inherits a public
function F with controlling result, and a derivation of T
is declared in the public part of another package, overriding
function F may be rejected by the compiler.
gcc/ada/
* sem_disp.adb (Find_Hidden_Overridden_Primitive): Check
public dispatching primitives of ancestors; previously,
only immediately-visible primitives were checked.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_disp.adb | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 9c498ee9a3f..fe822290e45 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -89,7 +89,9 @@ package body Sem_Disp is
-- to the found entity; otherwise return Empty.
--
-- This routine does not search for non-hidden primitives since they are
- -- covered by the normal Ada 2005 rules.
+ -- covered by the normal Ada 2005 rules. Its name was motivated by an
+ -- intermediate version of AI05-0125 where this term was proposed to
+ -- name these entities in the RM.
function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean;
-- Check whether a primitive operation is inherited from an operation
@@ -2403,7 +2405,7 @@ package body Sem_Disp is
Orig_Prim := Original_Corresponding_Operation (Prim);
if Orig_Prim /= Prim
- and then Is_Immediately_Visible (Orig_Prim)
+ and then not Is_Hidden (Orig_Prim)
then
Vis_Ancestor := First_Elmt (Vis_List);
while Present (Vis_Ancestor) loop
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 11/22] ada: Revert conditional installation of signal handlers on VxWorks
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (8 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 10/22] ada: Cannot override inherited function with controlling result Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 12/22] ada: Small cleanup in processing of primitive operations Marc Poulhiès
` (10 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Doug Rupp
From: Doug Rupp <rupp@adacore.com>
The conditional installation resulted in a semantic change, and
although it is likely what is ultimately wanted (since HW interrupts
are being reworked on VxWorks). However it must be done in concert
with other modifications for the new formulation of HW interrupts and
not in isolation.
gcc/ada/
* init.c [vxworks] (__gnat_install_handler): Revert to
installing signal handlers without regard to interrupt_state.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/init.c | 12 ++++--------
1 file changed, 4 insertions(+), 8 deletions(-)
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index acb8c7cc57e..93e73f53c64 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -2100,14 +2100,10 @@ __gnat_install_handler (void)
/* For VxWorks, install all signal handlers, since pragma Interrupt_State
applies to vectored hardware interrupts, not signals. */
- if (__gnat_get_interrupt_state (SIGFPE) != 's')
- sigaction (SIGFPE, &act, NULL);
- if (__gnat_get_interrupt_state (SIGILL) != 's')
- sigaction (SIGILL, &act, NULL);
- if (__gnat_get_interrupt_state (SIGSEGV) != 's')
- sigaction (SIGSEGV, &act, NULL);
- if (__gnat_get_interrupt_state (SIGBUS) != 's')
- sigaction (SIGBUS, &act, NULL);
+ sigaction (SIGFPE, &act, NULL);
+ sigaction (SIGILL, &act, NULL);
+ sigaction (SIGSEGV, &act, NULL);
+ sigaction (SIGBUS, &act, NULL);
#if defined(__leon__) && defined(_WRS_KERNEL)
/* Specific to the LEON VxWorks kernel run-time library */
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 12/22] ada: Small cleanup in processing of primitive operations
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (9 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 11/22] ada: Revert conditional installation of signal handlers on VxWorks Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 13/22] ada: Change error message on invalid RTS path Marc Poulhiès
` (9 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The processing of primitive operations is now always uniform for tagged and
untagged types, but the code contains left-overs from the time where it was
specific to tagged types, in particular for the handling of subtypes.
gcc/ada/
* einfo.ads (Direct_Primitive_Operations): Mention concurrent types
as well as GNAT extensions instead of implementation details.
(Primitive_Operations): Document that Direct_Primitive_Operations is
also used for concurrent types as a fallback.
* einfo-utils.adb (Primitive_Operations): Tweak formatting.
* exp_util.ads (Find_Prim_Op): Adjust description.
* exp_util.adb (Make_Subtype_From_Expr): In the private case with
unknown discriminants, always copy Direct_Primitive_Operations and
do not overwrite the Class_Wide_Type of the expression's base type.
* sem_ch3.adb (Analyze_Incomplete_Type_Decl): Tweak comment.
(Analyze_Subtype_Declaration): Remove older and now dead calls to
Set_Direct_Primitive_Operations. Tweak comment.
(Build_Derived_Private_Type): Likewise.
(Build_Derived_Record_Type): Likewise.
(Build_Discriminated_Subtype): Set Direct_Primitive_Operations in
all cases instead of just for tagged types.
(Complete_Private_Subtype): Likewise.
(Derived_Type_Declaration): Tweak comment.
* sem_ch4.ads (Try_Object_Operation): Adjust description.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/einfo-utils.adb | 4 +--
gcc/ada/einfo.ads | 34 ++++++++++++-----------
gcc/ada/exp_util.adb | 8 ++----
gcc/ada/exp_util.ads | 10 +++----
gcc/ada/sem_ch3.adb | 61 ++++++++++++++++++-----------------------
gcc/ada/sem_ch4.ads | 5 ++--
6 files changed, 55 insertions(+), 67 deletions(-)
diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 4c86ba1c3b1..c0c79f92e13 100644
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -2422,8 +2422,8 @@ package body Einfo.Utils is
begin
if Is_Concurrent_Type (Id) then
if Present (Corresponding_Record_Type (Id)) then
- return Direct_Primitive_Operations
- (Corresponding_Record_Type (Id));
+ return
+ Direct_Primitive_Operations (Corresponding_Record_Type (Id));
-- When expansion is disabled, the corresponding record type is
-- absent, but if this is a tagged type with ancestors, or if the
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index dd95ea051c1..de175310ee9 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -932,18 +932,17 @@ package Einfo is
-- subtypes. Contains the Digits value specified in the declaration.
-- Direct_Primitive_Operations
--- Defined in tagged types and subtypes (including synchronized types),
--- in tagged private types, and in tagged incomplete types. Moreover, it
--- is also defined for untagged types, both when Extensions_Allowed is
--- True (-gnatX) to support the extension feature of prefixed calls for
--- untagged types, and when Extensions_Allowed is False to get better
--- error messages. This field is an element list of entities for
--- primitive operations of the type. For incomplete types the list is
--- always empty. In order to follow the C++ ABI, entities of primitives
--- that come from source must be stored in this list in the order of
--- their occurrence in the sources. When expansion is disabled, the
--- corresponding record type of a synchronized type is not constructed.
--- In that case, such types carry this attribute directly.
+-- Defined in concurrent types, tagged record types and subtypes, tagged
+-- private types, and tagged incomplete types. Moreover, it is also
+-- defined in untagged types, both when GNAT extensions are allowed, to
+-- support prefixed calls for untagged types, and when GNAT extensions
+-- are not allowed, to give better error messages. Set to a list of
+-- entities for primitive operations of the type. For incomplete types
+-- the list is always empty. In order to follow the C++ ABI, entities of
+-- primitives that come from source must be stored in this list in the
+-- order of their occurrence in the sources. When expansion is disabled,
+-- the corresponding record type of concurrent types is not constructed;
+-- in this case, such types carry this attribute directly.
-- Directly_Designated_Type
-- Defined in access types. This field points to the type that is
@@ -4066,10 +4065,13 @@ package Einfo is
-- Primitive_Operations (synthesized)
-- Defined in concurrent types, tagged record types and subtypes, tagged
--- private types and tagged incomplete types. For concurrent types whose
--- Corresponding_Record_Type (CRT) is available, returns the list of
--- Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
--- For all the other types returns the Direct_Primitive_Operations.
+-- private types, and tagged incomplete types. Moreover, it is also
+-- defined in untagged types, both when GNAT extensions are allowed, to
+-- support prefixed calls for untagged types, and when GNAT extensions
+-- are not allowed, to give better error messages. For concurrent types
+-- whose Corresponding_Record_Type (CRT) is available, returns the list
+-- of Direct_Primitive_Operations of this CRT. In all the other cases,
+-- returns the list of Direct_Primitive_Operations.
-- Prival
-- Defined in private components of protected types. Refers to the entity
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 7a756af97ea..e86e7037d1f 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -10671,12 +10671,8 @@ package body Exp_Util is
Set_Is_Itype (Priv_Subtyp);
Set_Associated_Node_For_Itype (Priv_Subtyp, E);
- if Is_Tagged_Type (Priv_Subtyp) then
- Set_Class_Wide_Type
- (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
- Set_Direct_Primitive_Operations (Priv_Subtyp,
- Direct_Primitive_Operations (Unc_Typ));
- end if;
+ Set_Direct_Primitive_Operations
+ (Priv_Subtyp, Direct_Primitive_Operations (Unc_Typ));
Set_Full_View (Priv_Subtyp, Full_Subtyp);
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 16d8e14976c..6460bf02c1b 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -578,11 +578,11 @@ package Exp_Util is
-- Find the last initialization call related to object declaration Decl
function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
- -- Find the first primitive operation of a tagged type T with name Name.
- -- This function allows the use of a primitive operation which is not
- -- directly visible. If T is a class-wide type, then the reference is to an
- -- operation of the corresponding root type. It is an error if no primitive
- -- operation with the given name is found.
+ -- Find the first primitive operation of type T with the specified Name,
+ -- disregarding any visibility considerations. If T is a class-wide type,
+ -- then examine the primitive operations of its corresponding root type.
+ -- Raise Program_Error if no primitive operation with the specified Name
+ -- is found.
function Find_Prim_Op
(T : Entity_Id;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index fa13bd23ac7..391727a37f4 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3554,8 +3554,7 @@ package body Sem_Ch3 is
-- Initialize the list of primitive operations to an empty list,
-- to cover tagged types as well as untagged types. For untagged
-- types this is used either to analyze the call as legal when
- -- Core_Extensions_Allowed is True, or to issue a better error message
- -- otherwise.
+ -- GNAT extensions are allowed, or to give better error messages.
Set_Direct_Primitive_Operations (T, New_Elmt_List);
@@ -5864,8 +5863,6 @@ package body Sem_Ch3 is
Set_No_Tagged_Streams_Pragma
(Id, No_Tagged_Streams_Pragma (T));
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
- Set_Direct_Primitive_Operations
- (Id, Direct_Primitive_Operations (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
if Is_Interface (T) then
@@ -5895,8 +5892,6 @@ package body Sem_Ch3 is
No_Tagged_Streams_Pragma (T));
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
- Set_Direct_Primitive_Operations (Id,
- Direct_Primitive_Operations (T));
end if;
-- In general the attributes of the subtype of a private type
@@ -6000,16 +5995,6 @@ package body Sem_Ch3 is
(Id, No_Tagged_Streams_Pragma (T));
end if;
- -- For tagged types, or when prefixed-call syntax is allowed
- -- for untagged types, initialize the list of primitive
- -- operations to an empty list.
-
- if Is_Tagged_Type (Id)
- or else Core_Extensions_Allowed
- then
- Set_Direct_Primitive_Operations (Id, New_Elmt_List);
- end if;
-
-- Ada 2005 (AI-412): Decorate an incomplete subtype of an
-- incomplete type visible through a limited with clause.
@@ -6050,7 +6035,8 @@ package body Sem_Ch3 is
-- When prefixed calls are enabled for untagged types, the subtype
-- shares the primitive operations of its base type. Do this even
- -- when Extensions_Allowed is False to issue better error messages.
+ -- when GNAT extensions are not allowed, in order to give better
+ -- error messages.
Set_Direct_Primitive_Operations
(Id, Direct_Primitive_Operations (Base_Type (T)));
@@ -8462,8 +8448,7 @@ package body Sem_Ch3 is
-- Initialize the list of primitive operations to an empty list,
-- to cover tagged types as well as untagged types. For untagged
-- types this is used either to analyze the call as legal when
- -- Extensions_Allowed is True, or to issue a better error message
- -- otherwise.
+ -- GNAT extensions are allowed, or to give better error messages.
Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
@@ -9862,8 +9847,7 @@ package body Sem_Ch3 is
-- Initialize the list of primitive operations to an empty list,
-- to cover tagged types as well as untagged types. For untagged
-- types this is used either to analyze the call as legal when
- -- Extensions_Allowed is True, or to issue a better error message
- -- otherwise.
+ -- GNAT extensions are allowed, or to give better error messages.
Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
@@ -10911,6 +10895,14 @@ package body Sem_Ch3 is
Make_Class_Wide_Type (Def_Id);
end if;
+ -- When prefixed calls are enabled for untagged types, the subtype
+ -- shares the primitive operations of its base type. Do this even
+ -- when GNAT extensions are not allowed, in order to give better
+ -- error messages.
+
+ Set_Direct_Primitive_Operations
+ (Def_Id, Direct_Primitive_Operations (T));
+
Set_Stored_Constraint (Def_Id, No_Elist);
if Has_Discrs then
@@ -10921,17 +10913,11 @@ package body Sem_Ch3 is
if Is_Tagged_Type (T) then
-- Ada 2005 (AI-251): In case of concurrent types we inherit the
- -- concurrent record type (which has the list of primitive
- -- operations).
+ -- concurrent record type.
- if Ada_Version >= Ada_2005
- and then Is_Concurrent_Type (T)
- then
- Set_Corresponding_Record_Type (Def_Id,
- Corresponding_Record_Type (T));
- else
- Set_Direct_Primitive_Operations (Def_Id,
- Direct_Primitive_Operations (T));
+ if Ada_Version >= Ada_2005 and then Is_Concurrent_Type (T) then
+ Set_Corresponding_Record_Type
+ (Def_Id, Corresponding_Record_Type (T));
end if;
Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T));
@@ -13083,6 +13069,14 @@ package body Sem_Ch3 is
Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
Set_Depends_On_Private (Full, Has_Private_Component (Full));
+ -- When prefixed calls are enabled for untagged types, the subtype
+ -- shares the primitive operations of its base type. Do this even
+ -- when GNAT extensions are not allowed, in order to give better
+ -- error messages.
+
+ Set_Direct_Primitive_Operations
+ (Full, Direct_Primitive_Operations (Full_Base));
+
-- Freeze the private subtype entity if its parent is delayed, and not
-- already frozen. We skip this processing if the type is an anonymous
-- subtype of a record component, or is the corresponding record of a
@@ -13189,8 +13183,6 @@ package body Sem_Ch3 is
Set_Is_Tagged_Type (Full);
Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base));
- Set_Direct_Primitive_Operations
- (Full, Direct_Primitive_Operations (Full_Base));
Set_No_Tagged_Streams_Pragma
(Full, No_Tagged_Streams_Pragma (Full_Base));
@@ -17469,8 +17461,7 @@ package body Sem_Ch3 is
-- Initialize the list of primitive operations to an empty list,
-- to cover tagged types as well as untagged types. For untagged
-- types this is used either to analyze the call as legal when
- -- Extensions_Allowed is True, or to issue a better error message
- -- otherwise.
+ -- GNAT extensions are allowed, or to give better error messages.
Set_Direct_Primitive_Operations (T, New_Elmt_List);
diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads
index 7aae598b32a..dbe0f9a73da 100644
--- a/gcc/ada/sem_ch4.ads
+++ b/gcc/ada/sem_ch4.ads
@@ -84,9 +84,8 @@ package Sem_Ch4 is
-- true then N is an N_Selected_Component node which is part of a call to
-- an entry or procedure of a tagged concurrent type and this routine is
-- invoked to search for class-wide subprograms conflicting with the target
- -- entity. If Allow_Extensions is True, then a prefixed call of a primitive
- -- of a non-tagged type is allowed as if Extensions_Allowed returned True.
- -- This is used to issue better error messages.
+ -- entity. If Allow_Extensions is True, then a prefixed call to a primitive
+ -- of an untagged type is allowed (used to give better error messages).
procedure Unresolved_Operator (N : Node_Id);
-- Give an error for an unresolved operator
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 13/22] ada: Change error message on invalid RTS path
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (10 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 12/22] ada: Small cleanup in processing of primitive operations Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 14/22] ada: Crash when using user defined string literals Marc Poulhiès
` (8 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Marc Poulhiès
Include the invalid path in the error message.
gcc/ada/
* make.adb (Scan_Make_Arg): Adjust error message.
* gnatls.adb (Search_RTS): Likewise.
* switch-b.adb (Scan_Debug_Switches): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gnatls.adb | 11 ++++++++---
gcc/ada/make.adb | 14 +++++++++-----
gcc/ada/switch-b.adb | 15 ++++++++++-----
3 files changed, 27 insertions(+), 13 deletions(-)
diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
index 2c26001743a..c52c1aea9c3 100644
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -1673,9 +1673,13 @@ procedure Gnatls is
end if;
if Lib_Path /= null then
- Osint.Fail ("RTS path not valid: missing adainclude directory");
+ Osint.Fail
+ ("RTS path """ & Name
+ & """ not valid: missing adainclude directory");
elsif Src_Path /= null then
- Osint.Fail ("RTS path not valid: missing adalib directory");
+ Osint.Fail
+ ("RTS path """ & Name
+ & """ not valid: missing adalib directory");
end if;
-- Try to find the RTS on the project path. First setup the project path
@@ -1710,7 +1714,8 @@ procedure Gnatls is
end if;
Osint.Fail
- ("RTS path not valid: missing adainclude and adalib directories");
+ ("RTS path """ & Name
+ & """ not valid: missing adainclude and adalib directories");
end Search_RTS;
-------------------
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 24b2d099bfe..cef24341135 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -4478,13 +4478,14 @@ package body Make is
RTS_Switch := True;
declare
+ RTS_Arg_Path : constant String := Argv (7 .. Argv'Last);
Src_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
- (Argv (7 .. Argv'Last), Include);
+ (RTS_Arg_Path, Include);
Lib_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
- (Argv (7 .. Argv'Last), Objects);
+ (RTS_Arg_Path, Objects);
begin
if Src_Path_Name /= null
@@ -4501,16 +4502,19 @@ package body Make is
and then Lib_Path_Name = null
then
Make_Failed
- ("RTS path not valid: missing adainclude and adalib "
+ ("RTS path """ & RTS_Arg_Path
+ & """ not valid: missing adainclude and adalib "
& "directories");
elsif Src_Path_Name = null then
Make_Failed
- ("RTS path not valid: missing adainclude directory");
+ ("RTS path """ & RTS_Arg_Path
+ & """ not valid: missing adainclude directory");
else pragma Assert (Lib_Path_Name = null);
Make_Failed
- ("RTS path not valid: missing adalib directory");
+ ("RTS path """ & RTS_Arg_Path
+ & """ not valid: missing adalib directory");
end if;
end;
end if;
diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb
index 8d8dc58937c..2de516dba56 100644
--- a/gcc/ada/switch-b.adb
+++ b/gcc/ada/switch-b.adb
@@ -672,13 +672,15 @@ package body Switch.B is
Opt.RTS_Switch := True;
declare
+ RTS_Arg_Path : constant String :=
+ Switch_Chars (Ptr + 1 .. Max);
Src_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
- (Switch_Chars (Ptr + 1 .. Max),
+ (RTS_Arg_Path,
Include);
Lib_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
- (Switch_Chars (Ptr + 1 .. Max),
+ (RTS_Arg_Path,
Objects);
begin
@@ -698,14 +700,17 @@ package body Switch.B is
and then Lib_Path_Name = null
then
Osint.Fail
- ("RTS path not valid: missing adainclude and "
+ ("RTS path """ & RTS_Arg_Path
+ & """ not valid: missing adainclude and "
& "adalib directories");
elsif Src_Path_Name = null then
Osint.Fail
- ("RTS path not valid: missing adainclude directory");
+ ("RTS path """ & RTS_Arg_Path
+ & """ not valid: missing adainclude directory");
else pragma Assert (Lib_Path_Name = null);
Osint.Fail
- ("RTS path not valid: missing adalib directory");
+ ("RTS path """ & RTS_Arg_Path
+ & """ not valid: missing adalib directory");
end if;
end;
end if;
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 14/22] ada: Crash when using user defined string literals
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (11 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 13/22] ada: Change error message on invalid RTS path Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 15/22] ada: Fix crash in GNATbind during error reporting Marc Poulhiès
` (7 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Javier Miranda
From: Javier Miranda <miranda@adacore.com>
When a non-overridable aspect is explicitly specified for a
non-tagged derived type, the compiler blows up processing an
object declaration of an object of such type.
gcc/ada/
* sem_ch13.adb (Analyze_One_Aspect): Fix code locating the entity
of the parent type.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch13.adb | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index a86f774018a..90376f818a3 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -4801,8 +4801,14 @@ package body Sem_Ch13 is
and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
and then not In_Instance_Body
then
+ -- In order to locate the parent type we must go first to its
+ -- base type because the frontend introduces an implicit base
+ -- type even if there is no constraint attached to it, since
+ -- this is closer to the Ada semantics.
+
declare
- Parent_Type : constant Entity_Id := Etype (E);
+ Parent_Type : constant Entity_Id :=
+ Etype (Base_Type (E));
Inherited_Aspect : constant Node_Id :=
Find_Aspect (Parent_Type, A_Id);
begin
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 15/22] ada: Fix crash in GNATbind during error reporting
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (12 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 14/22] ada: Crash when using user defined string literals Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 16/22] ada: Apply fixes to Examine_Array_Bounds Marc Poulhiès
` (6 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This is the minimal fix to avoid the crash.
gcc/ada/
* bcheck.adb (Check_Consistency_Of_Sdep): Guard against path to ALI
file not found.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/bcheck.adb | 10 +++++++---
1 file changed, 7 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index 56a417cc517..64a6734a330 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -162,10 +162,14 @@ package body Bcheck is
end if;
else
- ALI_Path_Id :=
- Osint.Full_Lib_File_Name (A.Afile);
+ ALI_Path_Id := Osint.Full_Lib_File_Name (A.Afile);
+
+ -- Guard against Find_File not finding (again) the file because
+ -- Primary_Directory has been clobbered in between.
- if Osint.Is_Readonly_Library (ALI_Path_Id) then
+ if Present (ALI_Path_Id)
+ and then Osint.Is_Readonly_Library (ALI_Path_Id)
+ then
if Tolerate_Consistency_Errors then
Error_Msg ("?{ should be recompiled");
Error_Msg_File_1 := ALI_Path_Id;
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 16/22] ada: Apply fixes to Examine_Array_Bounds
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (13 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 15/22] ada: Fix crash in GNATbind during error reporting Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 17/22] ada: Reject ambiguous function calls in interpolated string expressions Marc Poulhiès
` (5 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Ronan Desplanques
From: Ronan Desplanques <desplanques@adacore.com>
gcc/ada/
* sem_util.adb (Examine_Array_Bounds): Add missing return
statements. Fix criterion for a string literal being empty.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_util.adb | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4cdac9443e6..4dde5f3964e 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -8157,13 +8157,15 @@ package body Sem_Util is
if not Is_Constrained (Typ) then
All_Static := False;
Has_Empty := False;
+ return;
-- A string literal has static bounds, and is not empty as long as it
-- contains at least one character.
elsif Ekind (Typ) = E_String_Literal_Subtype then
All_Static := True;
- Has_Empty := String_Literal_Length (Typ) > 0;
+ Has_Empty := String_Literal_Length (Typ) = 0;
+ return;
end if;
-- Assume that all bounds are static and not empty
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 17/22] ada: Reject ambiguous function calls in interpolated string expressions
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (14 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 16/22] ada: Apply fixes to Examine_Array_Bounds Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 18/22] ada: Implement fast modulo reduction for nonbinary modular multiplication Marc Poulhiès
` (4 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Javier Miranda
From: Javier Miranda <miranda@adacore.com>
When the interpolated expression is a call to an ambiguous call
the frontend does not reject it; erroneously accepts the call
and generates code that calls to one of them.
gcc/ada/
* sem_ch2.adb (Analyze_Interpolated_String_Literal): Reject
ambiguous function calls.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch2.adb | 10 ++++++++++
1 file changed, 10 insertions(+)
diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb
index aae9990eb4d..08cc75c9104 100644
--- a/gcc/ada/sem_ch2.adb
+++ b/gcc/ada/sem_ch2.adb
@@ -25,7 +25,9 @@
with Atree; use Atree;
with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
with Ghost; use Ghost;
with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
@@ -141,6 +143,14 @@ package body Sem_Ch2 is
Str_Elem := First (Expressions (N));
while Present (Str_Elem) loop
Analyze (Str_Elem);
+
+ if Nkind (Str_Elem) = N_Identifier
+ and then Ekind (Entity (Str_Elem)) = E_Function
+ and then Is_Overloaded (Str_Elem)
+ then
+ Error_Msg_NE ("ambiguous call to&", Str_Elem, Entity (Str_Elem));
+ end if;
+
Next (Str_Elem);
end loop;
end Analyze_Interpolated_String_Literal;
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 18/22] ada: Implement fast modulo reduction for nonbinary modular multiplication
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (15 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 17/22] ada: Reject ambiguous function calls in interpolated string expressions Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 19/22] " Marc Poulhiès
` (3 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This implements modulo reduction for nonbinary modular multiplication with
small moduli by means of the standard division-free algorithm also used in
the optimizer, but with fewer constraints and therefore better results.
For the sake of consistency, it is also used for the 'Mod attribute of the
same modular types and, more generally, for the Mod (and Rem) operators of
unsigned types if the second operand is static and not a power of two.
gcc/ada/
* gcc-interface/gigi.h (fast_modulo_reduction): Declare.
* gcc-interface/trans.cc (gnat_to_gnu) <N_Op_Mod>: In the unsigned
case, call fast_modulo_reduction for {FLOOR,TRUNC}_MOD_EXPR if the
RHS is a constant and not a power of two, and the precision is not
larger than the word size.
* gcc-interface/utils2.cc: Include expmed.h.
(fast_modulo_reduction): New function.
(nonbinary_modular_operation): Call fast_modulo_reduction for the
multiplication if the precision is not larger than the word size.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/gigi.h | 5 ++
gcc/ada/gcc-interface/trans.cc | 17 ++++++
gcc/ada/gcc-interface/utils2.cc | 102 +++++++++++++++++++++++++++++++-
3 files changed, 121 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 6ed74d6879e..40f3f0d3d13 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -1040,6 +1040,11 @@ extern bool simple_constant_p (Entity_Id gnat_entity);
/* Return the size of TYPE, which must be a positive power of 2. */
extern unsigned int resolve_atomic_size (tree type);
+/* Try to compute the reduction of OP modulo MODULUS in PRECISION bits with a
+ division-free algorithm. Return NULL_TREE if this is not easily doable. */
+extern tree fast_modulo_reduction (tree op, tree modulus,
+ unsigned int precision);
+
#ifdef __cplusplus
extern "C" {
#endif
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index e68fb3fd776..7c5282602b2 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -7317,6 +7317,23 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result
= build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs,
gnat_node);
+
+ /* For an unsigned modulo operation with nonbinary constant modulus,
+ we first try to do a reduction by means of a (multiplier, shifter)
+ pair in the needed precision up to the word size. But not when
+ optimizing for size, because it will be longer than a div+mul+sub
+ sequence. */
+ else if (!optimize_size
+ && (code == FLOOR_MOD_EXPR || code == TRUNC_MOD_EXPR)
+ && TYPE_UNSIGNED (gnu_type)
+ && TYPE_PRECISION (gnu_type) <= BITS_PER_WORD
+ && TREE_CODE (gnu_rhs) == INTEGER_CST
+ && !integer_pow2p (gnu_rhs)
+ && (gnu_expr
+ = fast_modulo_reduction (gnu_lhs, gnu_rhs,
+ TYPE_PRECISION (gnu_type))))
+ gnu_result = gnu_expr;
+
else
{
/* Some operations, e.g. comparisons of arrays, generate complex
diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
index 70271cf2836..a37eccc4cfb 100644
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -33,6 +33,7 @@
#include "tree.h"
#include "inchash.h"
#include "builtins.h"
+#include "expmed.h"
#include "fold-const.h"
#include "stor-layout.h"
#include "stringpool.h"
@@ -534,6 +535,91 @@ compare_fat_pointers (location_t loc, tree result_type, tree p1, tree p2)
p1_array_is_null, same_bounds));
}
+/* Try to compute the reduction of OP modulo MODULUS in PRECISION bits with a
+ division-free algorithm. Return NULL_TREE if this is not easily doable. */
+
+tree
+fast_modulo_reduction (tree op, tree modulus, unsigned int precision)
+{
+ const tree type = TREE_TYPE (op);
+ const unsigned int type_precision = TYPE_PRECISION (type);
+
+ /* The implementation is host-dependent for the time being. */
+ if (type_precision <= HOST_BITS_PER_WIDE_INT)
+ {
+ const unsigned HOST_WIDE_INT d = tree_to_uhwi (modulus);
+ unsigned HOST_WIDE_INT ml, mh;
+ int pre_shift, post_shift;
+ tree t;
+
+ /* The trick is to replace the division by d with a multiply-and-shift
+ sequence parameterized by a (multiplier, shifter) pair computed from
+ d, the precision of the type and the needed precision:
+
+ op / d = (op * multiplier) >> shifter
+
+ But choose_multiplier provides a slightly different interface:
+
+ op / d = (op h* multiplier) >> reduced_shifter
+
+ that makes things easier by using a high-part multiplication. */
+ mh = choose_multiplier (d, type_precision, precision, &ml, &post_shift);
+
+ /* If the suggested multiplier is more than TYPE_PRECISION bits, we can
+ do better for even divisors, using an initial right shift. */
+ if (mh != 0 && (d & 1) == 0)
+ {
+ pre_shift = ctz_or_zero (d);
+ mh = choose_multiplier (d >> pre_shift, type_precision,
+ precision - pre_shift, &ml, &post_shift);
+ }
+ else
+ pre_shift = 0;
+
+ /* If the suggested multiplier is still more than TYPE_PRECISION bits,
+ try again with a larger type up to the word size. */
+ if (mh != 0)
+ {
+ if (type_precision < BITS_PER_WORD)
+ {
+ const scalar_int_mode m
+ = smallest_int_mode_for_size (type_precision + 1);
+ tree new_type = gnat_type_for_mode (m, 1);
+ op = fold_convert (new_type, op);
+ modulus = fold_convert (new_type, modulus);
+ t = fast_modulo_reduction (op, modulus, precision);
+ if (t)
+ return fold_convert (type, t);
+ }
+
+ return NULL_TREE;
+ }
+
+ /* This computes op - (op / modulus) * modulus with PRECISION bits. */
+ op = gnat_protect_expr (op);
+
+ /* t = op >> pre_shift
+ t = t h* ml
+ t = t >> post_shift
+ t = t * modulus */
+ if (pre_shift)
+ t = fold_build2 (RSHIFT_EXPR, type, op,
+ build_int_cst (type, pre_shift));
+ else
+ t = op;
+ t = fold_build2 (MULT_HIGHPART_EXPR, type, t, build_int_cst (type, ml));
+ if (post_shift)
+ t = fold_build2 (RSHIFT_EXPR, type, t,
+ build_int_cst (type, post_shift));
+ t = fold_build2 (MULT_EXPR, type, t, modulus);
+
+ return fold_build2 (MINUS_EXPR, type, op, t);
+ }
+
+ else
+ return NULL_TREE;
+}
+
/* Compute the result of applying OP_CODE to LHS and RHS, where both are of
TYPE. We know that TYPE is a modular type with a nonbinary modulus. */
@@ -543,7 +629,7 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
{
tree modulus = TYPE_MODULUS (type);
unsigned precision = tree_floor_log2 (modulus) + 1;
- tree op_type, result;
+ tree op_type, result, fmr;
/* For the logical operations, we only need PRECISION bits. For addition and
subtraction, we need one more, and for multiplication twice as many. */
@@ -576,9 +662,19 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
if (op_code == MINUS_EXPR)
result = fold_build2 (PLUS_EXPR, op_type, result, modulus);
- /* For a multiplication, we have no choice but to use a modulo operation. */
+ /* For a multiplication, we first try to do a modulo reduction by means of a
+ (multiplier, shifter) pair in the needed precision up to the word size, or
+ else we fall back to a standard modulo operation. But not when optimizing
+ for size, because it will be longer than a div+mul+sub sequence. */
if (op_code == MULT_EXPR)
- result = fold_build2 (TRUNC_MOD_EXPR, op_type, result, modulus);
+ {
+ if (!optimize_size
+ && precision <= BITS_PER_WORD
+ && (fmr = fast_modulo_reduction (result, modulus, precision)))
+ result = fmr;
+ else
+ result = fold_build2 (TRUNC_MOD_EXPR, op_type, result, modulus);
+ }
/* For the other operations, subtract the modulus if we are >= it. */
else
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 19/22] ada: Implement fast modulo reduction for nonbinary modular multiplication
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (16 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 18/22] ada: Implement fast modulo reduction for nonbinary modular multiplication Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 20/22] ada: Fix bogus Address Sanitizer stack-buffer-overflow on packed record equality Marc Poulhiès
` (2 subsequent siblings)
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This adds the missing guard to prevent the reduction from being used when
the target does not provide or cannot synthesize a high-part multiply.
gcc/ada/
* gcc-interface/trans.cc (gnat_to_gnu) <N_Op_Mod>: Fix formatting.
* gcc-interface/utils2.cc: Include optabs-query.h.
(fast_modulo_reduction): Call can_mult_highpart_p on the TYPE_MODE
before generating a high-part multiply. Fix formatting.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 2 +-
gcc/ada/gcc-interface/utils2.cc | 12 +++++++-----
2 files changed, 8 insertions(+), 6 deletions(-)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 7c5282602b2..83ed17bff84 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -7323,7 +7323,7 @@ gnat_to_gnu (Node_Id gnat_node)
pair in the needed precision up to the word size. But not when
optimizing for size, because it will be longer than a div+mul+sub
sequence. */
- else if (!optimize_size
+ else if (!optimize_size
&& (code == FLOOR_MOD_EXPR || code == TRUNC_MOD_EXPR)
&& TYPE_UNSIGNED (gnu_type)
&& TYPE_PRECISION (gnu_type) <= BITS_PER_WORD
diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
index a37eccc4cfb..d101d7729bf 100644
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -35,6 +35,7 @@
#include "builtins.h"
#include "expmed.h"
#include "fold-const.h"
+#include "optabs-query.h"
#include "stor-layout.h"
#include "stringpool.h"
#include "varasm.h"
@@ -558,11 +559,11 @@ fast_modulo_reduction (tree op, tree modulus, unsigned int precision)
op / d = (op * multiplier) >> shifter
- But choose_multiplier provides a slightly different interface:
+ But choose_multiplier provides a slightly different interface:
- op / d = (op h* multiplier) >> reduced_shifter
+ op / d = (op h* multiplier) >> reduced_shifter
- that makes things easier by using a high-part multiplication. */
+ that makes things easier by using a high-part multiplication. */
mh = choose_multiplier (d, type_precision, precision, &ml, &post_shift);
/* If the suggested multiplier is more than TYPE_PRECISION bits, we can
@@ -577,8 +578,9 @@ fast_modulo_reduction (tree op, tree modulus, unsigned int precision)
pre_shift = 0;
/* If the suggested multiplier is still more than TYPE_PRECISION bits,
- try again with a larger type up to the word size. */
- if (mh != 0)
+ or the TYPE_MODE does not have a high-part multiply, try again with
+ a larger type up to the word size. */
+ if (mh != 0 || !can_mult_highpart_p (TYPE_MODE (type), true))
{
if (type_precision < BITS_PER_WORD)
{
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 20/22] ada: Fix bogus Address Sanitizer stack-buffer-overflow on packed record equality
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (17 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 19/22] " Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 21/22] ada: Fix bogus Address Sanitizer stack-buffer-overflow on packed array copy Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 22/22] ada: Fix internal error on protected type with -gnatc -gnatR Marc Poulhiès
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
We set DECL_BIT_FIELD optimistically during the translation of record types
and clear it afterward if needed, but fail to clear other attributes in the
latter case, which fools the logic of the Address Sanitizer.
gcc/ada/
* gcc-interface/utils.cc (clear_decl_bit_field): New function.
(finish_record_type): Call clear_decl_bit_field instead of clearing
DECL_BIT_FIELD manually.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/utils.cc | 26 +++++++++++++++++++-------
1 file changed, 19 insertions(+), 7 deletions(-)
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index 771cb1a17ca..0eb9af8d4a2 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -2002,6 +2002,21 @@ finish_fat_pointer_type (tree record_type, tree field_list)
TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2;
}
+/* Clear DECL_BIT_FIELD flag and associated markers on FIELD, which is a field
+ of aggregate type TYPE. */
+
+static void
+clear_decl_bit_field (tree field, tree type)
+{
+ DECL_BIT_FIELD (field) = 0;
+ DECL_BIT_FIELD_TYPE (field) = NULL_TREE;
+
+ /* DECL_BIT_FIELD_REPRESENTATIVE is not defined for QUAL_UNION_TYPE since
+ it uses the same slot as DECL_QUALIFIER. */
+ if (TREE_CODE (type) != QUAL_UNION_TYPE)
+ DECL_BIT_FIELD_REPRESENTATIVE (field) = NULL_TREE;
+}
+
/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
finish constructing the record or union type. If REP_LEVEL is zero, this
record has no representation clause and so will be entirely laid out here.
@@ -2112,7 +2127,7 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
if (TYPE_ALIGN (record_type) >= align)
{
SET_DECL_ALIGN (field, MAX (DECL_ALIGN (field), align));
- DECL_BIT_FIELD (field) = 0;
+ clear_decl_bit_field (field, record_type);
}
else if (!had_align
&& rep_level == 0
@@ -2122,7 +2137,7 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
{
SET_TYPE_ALIGN (record_type, align);
SET_DECL_ALIGN (field, MAX (DECL_ALIGN (field), align));
- DECL_BIT_FIELD (field) = 0;
+ clear_decl_bit_field (field, record_type);
}
}
@@ -2130,7 +2145,7 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
if (!STRICT_ALIGNMENT
&& DECL_BIT_FIELD (field)
&& value_factor_p (pos, BITS_PER_UNIT))
- DECL_BIT_FIELD (field) = 0;
+ clear_decl_bit_field (field, record_type);
}
/* Clear DECL_BIT_FIELD_TYPE for a variant part at offset 0, it's simply
@@ -2453,10 +2468,7 @@ rest_of_record_type_compilation (tree record_type)
avoid generating useless attributes for the field in DWARF. */
if (DECL_SIZE (old_field) == TYPE_SIZE (field_type)
&& value_factor_p (pos, BITS_PER_UNIT))
- {
- DECL_BIT_FIELD (new_field) = 0;
- DECL_BIT_FIELD_TYPE (new_field) = NULL_TREE;
- }
+ clear_decl_bit_field (new_field, new_record_type);
DECL_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
TYPE_FIELDS (new_record_type) = new_field;
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 21/22] ada: Fix bogus Address Sanitizer stack-buffer-overflow on packed array copy
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (18 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 20/22] ada: Fix bogus Address Sanitizer stack-buffer-overflow on packed record equality Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
2024-06-21 8:58 ` [COMMITTED 22/22] ada: Fix internal error on protected type with -gnatc -gnatR Marc Poulhiès
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The Address Sanitizer considers that the padding at the end of a justified
modular type may be accessed through the object, but it is never accessed
and therefore can always be reused.
gcc/ada/
* gcc-interface/decl.cc (gnat_to_gnu_entity) <discrete_type>: Set
the TYPE_JUSTIFIED_MODULAR_P flag earlier.
* gcc-interface/misc.cc (gnat_unit_size_without_reusable_padding):
New function.
(LANG_HOOKS_UNIT_SIZE_WITHOUT_REUSABLE_PADDING): Redefine to above
function.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/decl.cc | 2 +-
gcc/ada/gcc-interface/misc.cc | 17 ++++++++++++++++-
2 files changed, 17 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index aa31a888818..5b3a3b4961b 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -1976,6 +1976,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
+ TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
TYPE_PACKED (gnu_type) = 1;
TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
@@ -2006,7 +2007,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* We will output additional debug info manually below. */
finish_record_type (gnu_type, gnu_field, 2, false);
- TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
/* Make the original array type a parallel/debug type. Note that
gnat_get_array_descr_info needs a TYPE_IMPL_PACKED_ARRAY_P type
diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc
index b703f00d3c0..4f6f6774fe7 100644
--- a/gcc/ada/gcc-interface/misc.cc
+++ b/gcc/ada/gcc-interface/misc.cc
@@ -760,6 +760,19 @@ gnat_type_max_size (const_tree gnu_type)
return max_size_unit;
}
+/* Return the unit size of TYPE without reusable tail padding. */
+
+static tree
+gnat_unit_size_without_reusable_padding (tree type)
+{
+ /* The padding of justified modular types can always be reused. */
+ if (TYPE_JUSTIFIED_MODULAR_P (type))
+ return fold_convert (sizetype,
+ size_binop (CEIL_DIV_EXPR,
+ TYPE_ADA_SIZE (type), bitsize_unit_node));
+ return TYPE_SIZE_UNIT (type);
+}
+
static tree get_array_bit_stride (tree);
/* Provide information in INFO for debug output about the TYPE array type.
@@ -1407,6 +1420,8 @@ const struct scoped_attribute_specs *const gnat_attribute_table[] =
#define LANG_HOOKS_TYPE_FOR_SIZE gnat_type_for_size
#undef LANG_HOOKS_TYPES_COMPATIBLE_P
#define LANG_HOOKS_TYPES_COMPATIBLE_P gnat_types_compatible_p
+#undef LANG_HOOKS_UNIT_SIZE_WITHOUT_REUSABLE_PADDING
+#define LANG_HOOKS_UNIT_SIZE_WITHOUT_REUSABLE_PADDING gnat_unit_size_without_reusable_padding
#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
#define LANG_HOOKS_GET_ARRAY_DESCR_INFO gnat_get_array_descr_info
#undef LANG_HOOKS_GET_SUBRANGE_BOUNDS
@@ -1433,7 +1448,7 @@ const struct scoped_attribute_specs *const gnat_attribute_table[] =
#define LANG_HOOKS_DEEP_UNSHARING true
#undef LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS
#define LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS true
-#undef LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE
+#undef LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE
#define LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE gnat_get_sarif_source_language
struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread* [COMMITTED 22/22] ada: Fix internal error on protected type with -gnatc -gnatR
2024-06-21 8:57 [COMMITTED 01/22] ada: Spurious style error with mutiple square brackets Marc Poulhiès
` (19 preceding siblings ...)
2024-06-21 8:58 ` [COMMITTED 21/22] ada: Fix bogus Address Sanitizer stack-buffer-overflow on packed array copy Marc Poulhiès
@ 2024-06-21 8:58 ` Marc Poulhiès
20 siblings, 0 replies; 22+ messages in thread
From: Marc Poulhiès @ 2024-06-21 8:58 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
It occurs when the body of a protected subprogram is processed, because the
references to the components of the type have not been properly expanded.
gcc/ada/
* gcc-interface/trans.cc (Subprogram_Body_to_gnu): Also return early
for a protected subprogram in -gnatc mode.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 83ed17bff84..3f2eadd7b2b 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -3934,6 +3934,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
if (Is_Generic_Subprogram (gnat_subprog) || Is_Eliminated (gnat_subprog))
return;
+ /* Likewise if this is a protected subprogram and we are only annotating
+ types, as the required expansion of references did not take place. */
+ if (Convention (gnat_subprog) == Convention_Protected
+ && type_annotate_only)
+ return;
+
/* If this subprogram acts as its own spec, define it. Otherwise, just get
the already-elaborated tree node. However, if this subprogram had its
elaboration deferred, we will already have made a tree node for it. So
--
2.45.1
^ permalink raw reply [flat|nested] 22+ messages in thread