* [COMMITTED 01/16] ada: Remove unused name of aspect from Snames
@ 2024-06-14 7:36 Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 02/16] ada: Allow implicit dereferenced for uses of 'Super Marc Poulhiès
` (14 more replies)
0 siblings, 15 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
gcc/ada/
* snames.ads-tmpl (Name_Storage_Model): Delete.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/snames.ads-tmpl | 1 -
1 file changed, 1 deletion(-)
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 6cc66566907..699b8df5851 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -165,7 +165,6 @@ package Snames is
Name_Relaxed_Initialization : constant Name_Id := N + $;
Name_Stable_Properties : constant Name_Id := N + $;
Name_Static_Predicate : constant Name_Id := N + $;
- Name_Storage_Model : constant Name_Id := N + $;
Name_Storage_Model_Type : constant Name_Id := N + $;
Name_String_Literal : constant Name_Id := N + $;
Name_Synchronization : constant Name_Id := N + $;
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 02/16] ada: Allow implicit dereferenced for uses of 'Super
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 03/16] ada: Couple of small cleanups in semantic analysis of aspects Marc Poulhiès
` (13 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Justin Squirek
From: Justin Squirek <squirek@adacore.com>
This patch modifies the experimental 'Super attribute to allow an access-valued
prefix to be equivalent to Prefix.all'Super.
gcc/ada/
* sem_attr.adb:
(Analyze_Attribute): Add check for dereference.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 1 +
1 file changed, 1 insertion(+)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 22fbca45ac5..2563a92f2f0 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6688,6 +6688,7 @@ package body Sem_Attr is
Error_Msg_GNAT_Extension ("attribute %", Sloc (N));
Check_E0;
+ Check_Dereference;
-- Verify that we are looking at a type with ancestors
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 03/16] ada: Couple of small cleanups in semantic analysis of aspects
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 02/16] ada: Allow implicit dereferenced for uses of 'Super Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 04/16] ada: Missing initialization of multidimensional array using sliding Marc Poulhiès
` (12 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The first cleanup is to expose a consistent interface from Sem_Ch13 for the
analysis of aspects at various points of the program. The second cleanup is
to fix the awkward implementation of the analysis of the specification for
the aspects Stable_Properties, Designated_Storage_Model, Storage_Model_Type
and Aggregate, which are always delayed, and the incorrect placement of that
of the aspect Local_Restrictions, which is never delayed.
gcc/ada/
* freeze.adb (Freeze_All): Call Check_Aspects_At_End_Of_Declarations
to perform the visibility check for aspects.
* sem_ch13.ads (Check_Aspects_At_End_Of_Declarations): Declare.
(Check_Aspect_At_Freeze_Point): Move to...
(Check_Aspect_At_End_Of_Declarations): Move to...
* sem_ch13.adb (Check_Aspect_At_Freeze_Point): ...here.
(Check_Aspect_At_End_Of_Declarations): ...here.
(Analyze_Aspect_Specifications): Remove peculiar processing for
Stable_Properties, Designated_Storage_Model, Storage_Model_Type
and Aggregate. Move that of Local_Restrictions around. Reset
Aitem at the beginning of the loop for each aspect.
(Check_Aspects_At_End_Of_Declarations): New procedure.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/freeze.adb | 17 +--------
gcc/ada/sem_ch13.adb | 87 ++++++++++++++++++++++++++------------------
gcc/ada/sem_ch13.ads | 14 +++----
3 files changed, 58 insertions(+), 60 deletions(-)
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index c4c524f4685..523b026cc21 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -2645,22 +2645,7 @@ package body Freeze is
-- for a description of how we handle aspect visibility).
elsif Has_Delayed_Aspects (E) then
- declare
- Ritem : Node_Id;
-
- begin
- Ritem := First_Rep_Item (E);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Aspect_Specification
- and then Entity (Ritem) = E
- and then Is_Delayed_Aspect (Ritem)
- then
- Check_Aspect_At_End_Of_Declarations (Ritem);
- end if;
-
- Next_Rep_Item (Ritem);
- end loop;
- end;
+ Check_Aspects_At_End_Of_Declarations (E);
end if;
-- If an incomplete type is still not frozen, this may be a
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index d065dd8dfda..46a359fd7d6 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -150,6 +150,15 @@ package body Sem_Ch13 is
-- is inserted before the freeze node, and the body of the function is
-- inserted after the freeze node.
+ procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id);
+ -- Performs the processing of an aspect at the freeze all point and issues
+ -- appropriate error messages if the visibility has indeed changed. ASN is
+ -- the N_Aspect_Specification node for the aspect.
+
+ procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id);
+ -- Performs the processing of an aspect at the freeze point. ASN is the
+ -- N_Aspect_Specification node for the aspect.
+
procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
-- Called if both Storage_Pool and Storage_Size attribute definition
-- clauses (SP and SS) are present for entity Ent. Issue error message.
@@ -1669,7 +1678,6 @@ package body Sem_Ch13 is
-- Local variables
Aspect : Node_Id;
- Aitem : Node_Id := Empty;
Ent : Node_Id;
L : constant List_Id := Aspect_Specifications (N);
@@ -1722,7 +1730,12 @@ package body Sem_Ch13 is
Loc : constant Source_Ptr := Sloc (Aspect);
Nam : constant Name_Id := Chars (Id);
A_Id : constant Aspect_Id := Get_Aspect_Id (Nam);
+
+ Aitem : Node_Id := Empty;
+ -- The associated N_Pragma or N_Attribute_Definition_Clause
+
Anod : Node_Id;
+ -- An auxiliary node
Delay_Required : Boolean;
-- Set False if delay is not required
@@ -2949,19 +2962,6 @@ package body Sem_Ch13 is
end if;
end case;
- if Delay_Required
- and then (A_Id = Aspect_Stable_Properties
- or else A_Id = Aspect_Designated_Storage_Model
- or else A_Id = Aspect_Storage_Model_Type
- or else A_Id = Aspect_Aggregate)
- -- ??? It seems like we should do this for all aspects, not
- -- just these, but that causes as-yet-undiagnosed regressions.
-
- then
- Set_Has_Delayed_Aspects (E);
- Set_Is_Delayed_Aspect (Aspect);
- end if;
-
-- Check 13.1(9.2/5): A representation aspect of a subtype or type
-- shall not be specified (whether by a representation item or an
-- aspect_specification) before the type is completely defined
@@ -3307,6 +3307,9 @@ package body Sem_Ch13 is
-- External_Name, Link_Name
+ -- Only the legality checks are done during the analysis, thus
+ -- no delay is required.
+
when Aspect_External_Name
| Aspect_Link_Name
=>
@@ -4126,30 +4129,20 @@ package body Sem_Ch13 is
end if;
end if;
- Aitem := Empty;
-
when Aspect_Aggregate =>
-- We will be checking that the aspect is not specified on a
-- non-array type in Check_Aspect_At_Freeze_Point
Validate_Aspect_Aggregate (Expr);
- Record_Rep_Item (E, Aspect);
- goto Continue;
-
- when Aspect_Local_Restrictions =>
- Validate_Aspect_Local_Restrictions (E, Expr);
- Record_Rep_Item (E, Aspect);
- goto Continue;
when Aspect_Stable_Properties =>
Validate_Aspect_Stable_Properties
(E, Expr, Class_Present => Class_Present (Aspect));
- Record_Rep_Item (E, Aspect);
- goto Continue;
when Aspect_Designated_Storage_Model =>
if not All_Extensions_Allowed then
Error_Msg_GNAT_Extension ("aspect %", Loc);
+ goto Continue;
elsif not Is_Type (E)
or else Ekind (E) /= E_Access_Type
@@ -4157,14 +4150,13 @@ package body Sem_Ch13 is
Error_Msg_N
("can only be specified for pool-specific access type",
Aspect);
+ goto Continue;
end if;
- Record_Rep_Item (E, Aspect);
- goto Continue;
-
when Aspect_Storage_Model_Type =>
if not All_Extensions_Allowed then
Error_Msg_GNAT_Extension ("aspect %", Loc);
+ goto Continue;
elsif not Is_Type (E)
or else not Is_Immutably_Limited_Type (E)
@@ -4172,11 +4164,9 @@ package body Sem_Ch13 is
Error_Msg_N
("can only be specified for immutably limited type",
Aspect);
+ goto Continue;
end if;
- Record_Rep_Item (E, Aspect);
- goto Continue;
-
when Aspect_Integer_Literal
| Aspect_Real_Literal
| Aspect_String_Literal
@@ -4193,16 +4183,13 @@ package body Sem_Ch13 is
(No_Implementation_Aspect_Specifications, N);
end if;
- Aitem := Empty;
-
-- Case 3b: The aspects listed below don't correspond to
-- pragmas/attributes and don't need delayed analysis.
-- Implicit_Dereference
- -- For Implicit_Dereference, External_Name and Link_Name, only
- -- the legality checks are done during the analysis, thus no
- -- delay is required.
+ -- Only the legality checks are done during the analysis, thus
+ -- no delay is required.
when Aspect_Implicit_Dereference =>
Analyze_Aspect_Implicit_Dereference;
@@ -4220,6 +4207,11 @@ package body Sem_Ch13 is
Analyze_Aspect_Dimension_System (N, Id, Expr);
goto Continue;
+ when Aspect_Local_Restrictions =>
+ Validate_Aspect_Local_Restrictions (E, Expr);
+ Record_Rep_Item (E, Aspect);
+ goto Continue;
+
-- Case 4: Aspects requiring special handling
-- Pre/Post/Test_Case/Contract_Cases/Always_Terminates/
@@ -4806,6 +4798,7 @@ package body Sem_Ch13 is
end if;
end;
end if;
+
exception
when Aspect_Exit => null;
end Analyze_One_Aspect;
@@ -11157,6 +11150,28 @@ package body Sem_Ch13 is
end if;
end Check_Aspect_At_End_Of_Declarations;
+ ------------------------------------------
+ -- Check_Aspects_At_End_Of_Declarations --
+ ------------------------------------------
+
+ procedure Check_Aspects_At_End_Of_Declarations (E : Entity_Id) is
+ ASN : Node_Id;
+
+ begin
+ ASN := First_Rep_Item (E);
+
+ while Present (ASN) loop
+ if Nkind (ASN) = N_Aspect_Specification
+ and then Entity (ASN) = E
+ and then Is_Delayed_Aspect (ASN)
+ then
+ Check_Aspect_At_End_Of_Declarations (ASN);
+ end if;
+
+ Next_Rep_Item (ASN);
+ end loop;
+ end Check_Aspects_At_End_Of_Declarations;
+
----------------------------------
-- Check_Aspect_At_Freeze_Point --
----------------------------------
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index 3c48a493c75..2bdca957826 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -312,18 +312,16 @@ package Sem_Ch13 is
-- Quite an awkward approach, but this is an awkard requirement
procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id);
- -- Analyze all the delayed aspects for entity E at freezing point. This
+ -- Analyzes all the delayed aspects for entity E at freezing point. This
-- includes dealing with inheriting delayed aspects from the parent type
- -- in the case where a derived type is frozen.
+ -- in the case where a derived type is frozen. Callers should check that
+ -- Has_Delayed_Aspects (E) is True before calling this routine.
- procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id);
- -- Performs the processing described above at the freeze point, ASN is the
- -- N_Aspect_Specification node for the aspect.
-
- procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id);
+ procedure Check_Aspects_At_End_Of_Declarations (E : Entity_Id);
-- Performs the processing described above at the freeze all point, and
-- issues appropriate error messages if the visibility has indeed changed.
- -- Again, ASN is the N_Aspect_Specification node for the aspect.
+ -- Callers should check that Has_Delayed_Aspects (E) is True before calling
+ -- this routine.
procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id);
-- Given an entity Typ that denotes a derived type or a subtype, this
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 04/16] ada: Missing initialization of multidimensional array using sliding
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 02/16] ada: Allow implicit dereferenced for uses of 'Super Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 03/16] ada: Couple of small cleanups in semantic analysis of aspects Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 05/16] ada: Minor tweaks to processing of Aggregate aspect Marc Poulhiès
` (11 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Javier Miranda
From: Javier Miranda <miranda@adacore.com>
When a multidimensional array is initialized with an array
aggregate, and inner dimensions of the array are initialized
with array subaggregates using sliding, the code generated
by the compiler does not initialize the inner dimensions
of the array.
gcc/ada/
* exp_aggr.adb (Must_Slide): Add missing support for
multidimensional arrays.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 54 +++++++++++++++++++++++++++-----------------
1 file changed, 33 insertions(+), 21 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 796b0f1e0de..2686f5b3b82 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -154,8 +154,8 @@ package body Exp_Aggr is
-- case the aggregate must slide, and we must introduce an intermediate
-- temporary to hold it.
--
- -- The same holds in an assignment to one-dimensional array of arrays,
- -- when a component may be given with bounds that differ from those of the
+ -- The same holds in an assignment to multi-dimensional arrays, when
+ -- components may be given with bounds that differ from those of the
-- component type.
function Number_Of_Choices (N : Node_Id) return Nat;
@@ -9550,32 +9550,44 @@ package body Exp_Aggr is
elsif Is_Others_Aggregate (Aggr) then
return False;
- else
- -- Sliding can only occur along the first dimension
- -- If any the bounds of non-static sliding is required
- -- to force potential range checks.
+ -- Check if sliding is required
+ else
declare
- Bounds1 : constant Range_Nodes :=
- Get_Index_Bounds (First_Index (Typ));
- Bounds2 : constant Range_Nodes :=
- Get_Index_Bounds (First_Index (Obj_Type));
+ Obj_Index : Node_Id := First_Index (Obj_Type);
+ Obj_Bounds : Range_Nodes;
+ Typ_Index : Node_Id := First_Index (Typ);
+ Typ_Bounds : Range_Nodes;
begin
- if not Is_OK_Static_Expression (Bounds1.First) or else
- not Is_OK_Static_Expression (Bounds2.First) or else
- not Is_OK_Static_Expression (Bounds1.Last) or else
- not Is_OK_Static_Expression (Bounds2.Last)
- then
- return True;
+ while Present (Typ_Index) loop
+ pragma Assert (Present (Obj_Index));
- else
- return Expr_Value (Bounds1.First) /= Expr_Value (Bounds2.First)
- or else
- Expr_Value (Bounds1.Last) /= Expr_Value (Bounds2.Last);
- end if;
+ Typ_Bounds := Get_Index_Bounds (Typ_Index);
+ Obj_Bounds := Get_Index_Bounds (Obj_Index);
+
+ if not Is_OK_Static_Expression (Typ_Bounds.First) or else
+ not Is_OK_Static_Expression (Obj_Bounds.First) or else
+ not Is_OK_Static_Expression (Typ_Bounds.Last) or else
+ not Is_OK_Static_Expression (Obj_Bounds.Last)
+ then
+ return True;
+
+ elsif Expr_Value (Typ_Bounds.First)
+ /= Expr_Value (Obj_Bounds.First)
+ or else Expr_Value (Typ_Bounds.Last)
+ /= Expr_Value (Obj_Bounds.Last)
+ then
+ return True;
+ end if;
+
+ Next_Index (Typ_Index);
+ Next_Index (Obj_Index);
+ end loop;
end;
end if;
+
+ return False;
end Must_Slide;
---------------------
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 05/16] ada: Minor tweaks to processing of Aggregate aspect
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (2 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 04/16] ada: Missing initialization of multidimensional array using sliding Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 06/16] ada: Crash checking accessibility level on private type Marc Poulhiès
` (10 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The main one is to give the error for Aggregate applied to array types from
Analyze_Aspects_At_Freeze_Point instead of Check_Aspect_At_Freeze_Point, as
for the other aspects. The message is also changed to be more direct.
gcc/ada/
* aspects.ads (Operational_Aspect): Alphabetize.
* sem_ch13.ads (Analyze_Aspects_At_Freeze_Point): Fix description.
* sem_ch13.adb (Analyze_Aspects_At_Freeze_Point) <Aggregate>: Give
the error for array types here instead of...
(Analyze_Aspect_Specifications) <Aggregate>: Adjust comment.
(Check_Aspect_At_Freeze_Point) <Aggregate>: ...here.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 4 ++--
gcc/ada/sem_ch13.adb | 17 ++++++++---------
gcc/ada/sem_ch13.ads | 9 +++++----
3 files changed, 15 insertions(+), 15 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 3cc62de3411..1acbec87824 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -325,12 +325,12 @@ package Aspects is
-- List is currently incomplete ???
Operational_Aspect : constant array (Aspect_Id) of Boolean :=
- (Aspect_Constant_Indexing => True,
+ (Aspect_Aggregate => True,
+ Aspect_Constant_Indexing => True,
Aspect_Default_Iterator => True,
Aspect_Iterator_Element => True,
Aspect_Iterable => True,
Aspect_Variable_Indexing => True,
- Aspect_Aggregate => True,
others => False);
-- The following array indicates aspects for which multiple occurrences of
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 46a359fd7d6..caebe2e793e 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1367,7 +1367,11 @@ package body Sem_Ch13 is
Validate_Storage_Model_Type_Aspect (E, ASN);
when Aspect_Aggregate =>
- null;
+ if Is_Array_Type (E) then
+ Error_Msg_N
+ ("aspect Aggregate may not be applied to array type",
+ ASN);
+ end if;
when others =>
null;
@@ -1384,7 +1388,7 @@ package body Sem_Ch13 is
Next_Rep_Item (ASN);
end loop;
- -- Make a second pass for a Full_Access_Only entry
+ -- Make a second pass for a Full_Access_Only entry, see above why
ASN := First_Rep_Item (E);
while Present (ASN) loop
@@ -4130,8 +4134,8 @@ package body Sem_Ch13 is
end if;
when Aspect_Aggregate =>
- -- We will be checking that the aspect is not specified on a
- -- non-array type in Check_Aspect_At_Freeze_Point
+ -- We will be checking that the aspect is not specified on
+ -- an array type in Analyze_Aspects_At_Freeze_Point.
Validate_Aspect_Aggregate (Expr);
@@ -11378,11 +11382,6 @@ package body Sem_Ch13 is
return;
when Aspect_Aggregate =>
- if Is_Array_Type (Entity (ASN)) then
- Error_Msg_N
- ("aspect& can only be applied to non-array type",
- Ident);
- end if;
Resolve_Aspect_Aggregate (Entity (ASN), Expression (ASN));
return;
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index 2bdca957826..aeacda833d1 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -312,10 +312,11 @@ package Sem_Ch13 is
-- Quite an awkward approach, but this is an awkard requirement
procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id);
- -- Analyzes all the delayed aspects for entity E at freezing point. This
- -- includes dealing with inheriting delayed aspects from the parent type
- -- in the case where a derived type is frozen. Callers should check that
- -- Has_Delayed_Aspects (E) is True before calling this routine.
+ -- Analyzes all the delayed aspects for entity E at the freeze point. Note
+ -- that this does not include dealing with inheriting delayed aspects from
+ -- the parent or base type in the case where a derived type or a subtype is
+ -- frozen. Callers should check that Has_Delayed_Aspects (E) is True before
+ -- calling this routine.
procedure Check_Aspects_At_End_Of_Declarations (E : Entity_Id);
-- Performs the processing described above at the freeze all point, and
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 06/16] ada: Crash checking accessibility level on private type
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (3 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 05/16] ada: Minor tweaks to processing of Aggregate aspect Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 07/16] ada: Add prototype for mutably tagged types Marc Poulhiès
` (9 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Justin Squirek
From: Justin Squirek <squirek@adacore.com>
This patch fixes an issue in the compiler whereby calculating a static
accessibility level on a private type with an access discriminant resulted
in a compile time crash when No_Dynamic_Accessibility_Checks is enabled.
gcc/ada/
* accessibility.adb:
(Accessibility_Level): Replace call Get_Full_View with call to
Full_View since Get_Full_View only works with incomplete types.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 47b3a7af10a..da4d1d9ce2e 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -2227,7 +2227,11 @@ package body Accessibility is
-- that of the type.
elsif Ekind (Def_Ent) = E_Discriminant then
- return Scope_Depth (Get_Full_View (Scope (Def_Ent)));
+ return Scope_Depth
+ (if Present (Full_View (Scope (Def_Ent))) then
+ Full_View (Scope (Def_Ent))
+ else
+ Scope (Def_Ent));
end if;
end if;
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 07/16] ada: Add prototype for mutably tagged types
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (4 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 06/16] ada: Crash checking accessibility level on private type Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 08/16] ada: Minor tweak in Snames Marc Poulhiès
` (8 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Justin Squirek
From: Justin Squirek <squirek@adacore.com>
This patch implements mutably tagged types via the new Size'Class aspect.
gcc/ada/
* doc/gnat_rm/gnat_language_extensions.rst: Add documentation for
mutably tagged type feature.
* aspects.ads: Add registration for 'Size'Class.
* einfo.ads: Add documentation for new components
Class_Wide_Equivalent_Type and Is_Mutably_Tagged_Type.
* exp_aggr.adb (Gen_Assign): Assume associated mutably tagged type
when class-wide equivalent type is encountered.
(Contains_Mutably_Tagged_Type): New subprogram.
(Convert_To_Positional): Assume associated mutably tagged type
when class-wide equivalent type is encountered.
(Is_Static_Element): Assume associated mutably tagged type when
class-wide equivalent type is encountered.
(Expand_Array_Aggregate): Assume associated mutably tagged type
when class-wide equivalent type is encountered.
(Expand_Record_Aggregate): Force mutably tagged records to be
expanded into assignments.
* exp_ch3.adb (Build_Array_Init_Proc): Assume associated mutably
tagged type when class-wide equivalent type is encountered.
(Simple_Initialization_OK): Disallow simple initialization for
class-wide equivalent types.
(Build_Init_Statements): Assume associated mutably tagged type
when class-wide equivalent type is encountered.
(Expand_Freeze_Array_Type): Ignore building of record init procs
for mutably tagged types.
(Expand_N_Full_Type_Declaration): Replace mutably tagged type
declarations with their associated class-wide equivalent types.
(Default_Initialize_Object): Add special handling for mutably
tagged types.
* exp_ch4.adb (Expand_N_Allocator): Add initialization for mutably
tagged types.
(Expand_Record_Equality): Generate mutably tagged unchecked
conversions.
* exp_ch5.adb (Expand_N_Assignment_Statement): Generate a special
assignment case for class-wide equivalent types which does tag
assignments and ignores certain checks.
* exp_ch6.adb (Expand_Call_Helper): Propagate constrained extra
formal actuals for mutably tagged types.
* exp_ch7.adb (Make_Init_Call): Handle mutably tagged type
initialization.
* exp_util.adb (Make_CW_Equivalent_Type): Modify to handle mutably
tagged objects which contain no initialization expression.
(Make_Subtype_From_Expr): Modify call to Make_CW_Equivalent_Type.
* exp_util.ads (Make_CW_Equivalent_Type): Move declaration from
body to spec.
* freeze.adb (Size_Known): No longer return false automatically
when a class-wide type is encountered.
(Freeze_Entity): Ignore error messages about size not being known
for mutably tagged types.
* gen_il-fields.ads: Register new fields
Class_Wide_Equivalent_Type and Is_Mutably_Tagged_Type.
* gen_il-gen-gen_entities.adb: Register new fields
Class_Wide_Equivalent_Type and Is_Mutably_Tagged_Type for type
entities.
* mutably_tagged.adb, mutably_tagged.ads
(Corresponding_Mutably_Tagged_Type): New subprogram.
(Depends_On_Mutably_Tagged_Ext_Comp): New subprogram.
(Get_Corresponding_Mutably_Tagged_Type_If_Present): New
subprogram.
(Get_Corresponding_Tagged_Type_If_Present): New subprogram.
(Is_Mutably_Tagged_Conversion): New subprogram.
(Is_Mutably_Tagged_CW_Equivalent_Type): New subprogram.
(Make_Mutably_Tagged_Conversion): New subprogram.
(Make_CW_Size_Compile_Check): New subprogram.
(Make_Mutably_Tagged_CW_Check): New subprogram.
* sem_aggr.adb (Resolve_Array_Aggregate): Skip tag checks for
class-wide equivalent types.
(Resolve_Aggr_Expr): Assume associated mutably tagged type when
class-wide equivalent type is encountered.
* sem_attr.adb (Analyze_Attribute): Allow 'Tag on mutably tagged
types.
(Resolve_Attribute): Detect errors for dependence of mutably
tagged extension type component.
* sem_ch12.adb (Instantiate_Object): Detect errors for dependence
of mutably tagged extension type component.
* sem_ch13.adb (Analyze_One_Aspect): Propagate 'Size'Class to
class-wide type.
(Analyze_Attribute_Definition_Clause): Add handling of 'Size'Class
by generating class-wide equivalent types and checking for illegal
uses.
* sem_ch2.adb (Analyze_Identifier): Generate unchecked conversion
for class-wide equivalent types.
* sem_ch3.adb (Analyze_Component_Declaration): Avoid unconstrained
errors on mutably tagged types.
(Analyze_Object_Declaration): Rewrite declarations of mutably
tagged types to use class-wide equivalent types.
(Array_Type_Declaration): Modify arrays of mutably tagged types to
use their corresponding class-wide equivalent types.
(Derived_Type_Declaration): Add various checks for mutably tagged
derived types.
* sem_ch4.adb (Analyze_Allocator): Replace reference to mutably
tagged type with cooresponding tagged type.
(Process_Indexed_Component): Generate unchecked conversion for
class-wide equivalent type.
(Analyze_One_Call): Generate unchecked conversion for class-wide
equivalent types.
(Analyze_Selected_Component): Assume reference to class-wide
equivalent type is associated mutably tagged type.
(Analyze_Type_Conversion): Generate unchecked conversion for
class-wide equivalent type.
* sem_ch5.adb (Analyze_Assignment): Assume associated mutably
tagged type when class-wide equivalent type is encountered.
(Analyze_Iterator_Specification): Detect errors for dependence of
mutably tagged extension type component.
* sem_ch6.adb (Create_Extra_Formals): Add code to generate extra
formal for mutably tagged types to signal if they are constrained.
* sem_ch8.adb (Analyze_Object_Renaming): Detect error on renaming
of mutably tagged extension type component.
(Analyze_Renaming_Primitive_Operation): Detect error on renaming
of mutably tagged extension type component.
* sem_res.adb (Resolve_Actuals): Allow class-wide arguments on
class-wide equivalent types.
(Valid_Conversion): Assume associated mutably tagged type when
class-wide equivalent type is encountered.
* sem_util.adb (Is_Fully_Initialized_Type): Flag mutably tagged
types as fully initialized.
(Needs_Simple_Initalization): Flag class-wide equivalent types as
needing initialization.
* gnat_rm.texi: Regenerate.
* gcc-interface/Make-lang.in: Add entry for mutably_tagged.o.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 1 +
.../doc/gnat_rm/gnat_language_extensions.rst | 38 ++
gcc/ada/einfo.ads | 8 +
gcc/ada/exp_aggr.adb | 66 +++-
gcc/ada/exp_ch3.adb | 64 +++-
gcc/ada/exp_ch4.adb | 51 ++-
gcc/ada/exp_ch5.adb | 80 ++++-
gcc/ada/exp_ch6.adb | 6 +-
gcc/ada/exp_ch7.adb | 3 +
gcc/ada/exp_util.adb | 64 ++--
gcc/ada/exp_util.ads | 20 ++
gcc/ada/freeze.adb | 8 +-
gcc/ada/gcc-interface/Make-lang.in | 1 +
gcc/ada/gen_il-fields.ads | 2 +
gcc/ada/gen_il-gen-gen_entities.adb | 2 +
gcc/ada/gnat_rm.texi | 106 ++++--
gcc/ada/mutably_tagged.adb | 337 ++++++++++++++++++
gcc/ada/mutably_tagged.ads | 120 +++++++
gcc/ada/sem_aggr.adb | 24 +-
gcc/ada/sem_attr.adb | 10 +-
gcc/ada/sem_ch12.adb | 5 +
gcc/ada/sem_ch13.adb | 74 ++++
gcc/ada/sem_ch2.adb | 7 +
gcc/ada/sem_ch3.adb | 122 ++++++-
gcc/ada/sem_ch4.adb | 61 +++-
gcc/ada/sem_ch5.adb | 36 +-
gcc/ada/sem_ch6.adb | 10 +-
gcc/ada/sem_ch8.adb | 9 +
gcc/ada/sem_res.adb | 17 +
gcc/ada/sem_util.adb | 13 +
30 files changed, 1235 insertions(+), 130 deletions(-)
create mode 100644 gcc/ada/mutably_tagged.adb
create mode 100644 gcc/ada/mutably_tagged.ads
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 1acbec87824..d4aafb1a4f1 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -260,6 +260,7 @@ package Aspects is
Aspect_Post => True,
Aspect_Read => True,
Aspect_Write => True,
+ Aspect_Size => True,
Aspect_Stable_Properties => True,
Aspect_Type_Invariant => True,
others => False);
diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
index c703e1c7e3f..cf1ad60f13c 100644
--- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
+++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
@@ -496,3 +496,41 @@ case statement with composite selector type".
Link to the original RFC:
https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-pattern-matching.rst
+
+Mutably Tagged Types with Size'Class Aspect
+-------------------------------------------
+
+The `Size'Class` aspect can be applied to a tagged type to specify a size
+constraint for the type and its descendants. When this aspect is specified
+on a tagged type, the class-wide type of that type is considered to be a
+"mutably tagged" type - meaning that objects of the class-wide type can have
+their tag changed by assignment from objects with a different tag.
+
+When the aspect is applied to a type, the size of each of its descendant types
+must not exceed the size specified for the aspect.
+
+Example:
+
+.. code-block:: ada
+
+ type Base is tagged null record
+ with Size'Class => 16 * 8; -- Size in bits (128 bits, or 16 bytes)
+
+ type Derived_Type is new Base with record
+ Data_Field : Integer;
+ end record; -- ERROR if Derived_Type exceeds 16 bytes
+
+Class-wide types with a specified `Size'Class` can be used as the type of
+array components, record components, and stand-alone objects.
+
+.. code-block:: ada
+
+ Inst : Base'Class;
+ type Array_of_Base is array (Positive range <>) of Base'Class;
+
+Note: Legality of the `Size'Class` aspect is subject to certain restrictions on
+the tagged type, such as being undiscriminated, having no dynamic composite
+subcomponents, among others detailed in the RFC.
+
+Link to the original RFC:
+https://github.com/AdaCore/ada-spark-rfcs/blob/topic/rfc-finally/considered/rfc-class-size.md
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 0b0529a39cf..8ee419b3e07 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -633,6 +633,10 @@ package Einfo is
-- the corresponding implicitly declared class-wide type. For a
-- class-wide type, returns itself. Set to Empty for untagged types.
+-- Class_Wide_Equivalent_Type
+-- Defined in all type entities. Used to store an internally generated
+-- class-wide equivalent type for an associated mutably tagged type.
+
-- Cloned_Subtype
-- Defined in E_Record_Subtype and E_Class_Wide_Subtype entities.
-- Each such entity can either have a Discriminant_Constraint, in
@@ -2980,6 +2984,10 @@ package Einfo is
-- Is_Modular_Integer_Type (synthesized)
-- Applies to all entities. True if entity is a modular integer type
+-- Is_Mutably_Tagged_Type
+-- Defined in all type entities. Used to signify that a given type is a
+-- "mutably tagged" class-wide type where 'Size'Class has been specified.
+
-- Is_Non_Static_Subtype
-- Defined in all type and subtype entities. It is set in some (but not
-- all) cases in which a subtype is known to be non-static. Before this
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 2686f5b3b82..d564fd4f755 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -43,6 +43,7 @@ with Exp_Tss; use Exp_Tss;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib; use Lib;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
@@ -1370,8 +1371,8 @@ package body Exp_Aggr is
Expr_Q := Unqualify (Expr);
if Present (Etype (N)) and then Etype (N) /= Any_Composite then
- Comp_Typ := Component_Type (Etype (N));
- pragma Assert (Comp_Typ = Ctype); -- AI-287
+ Comp_Typ := Get_Corresponding_Mutably_Tagged_Type_If_Present
+ (Component_Type (Etype (N)));
elsif Present (Next (First (New_Indexes))) then
@@ -4474,7 +4475,8 @@ package body Exp_Aggr is
Dims : constant Nat := Number_Dimensions (Typ);
Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N);
- Static_Components : Boolean := True;
+ Ctyp : Entity_Id := Component_Type (Typ);
+ Static_Components : Boolean := True;
procedure Check_Static_Components;
-- Check whether all components of the aggregate are compile-time known
@@ -4908,9 +4910,9 @@ package body Exp_Aggr is
end if;
end Is_Flat;
- -------------------------
- -- Is_Static_Element --
- -------------------------
+ -----------------------
+ -- Is_Static_Element --
+ -----------------------
function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean is
Expr : constant Node_Id := Expression (N);
@@ -4935,7 +4937,7 @@ package body Exp_Aggr is
-- but only at the innermost level for a multidimensional array.
elsif Dims = 1 then
- Preanalyze_And_Resolve (Expr, Component_Type (Typ));
+ Preanalyze_And_Resolve (Expr, Ctyp);
return Compile_Time_Known_Value (Expr);
else
@@ -4986,6 +4988,10 @@ package body Exp_Aggr is
return;
end if;
+ -- Special handling for mutably taggeds
+
+ Ctyp := Get_Corresponding_Mutably_Tagged_Type_If_Present (Ctyp);
+
Check_Static_Components;
-- If the size is known, or all the components are static, try to
@@ -5076,9 +5082,10 @@ package body Exp_Aggr is
procedure Expand_Array_Aggregate (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Ctyp : constant Entity_Id := Component_Type (Typ);
+ Typ : constant Entity_Id := Etype (N);
-- Typ is the correct constrained array subtype of the aggregate
+
+ Ctyp : Entity_Id := Component_Type (Typ);
-- Ctyp is the corresponding component type.
Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
@@ -6027,6 +6034,10 @@ package body Exp_Aggr is
pragma Assert (not Raises_Constraint_Error (N));
+ -- Special handling for mutably taggeds
+
+ Ctyp := Get_Corresponding_Mutably_Tagged_Type_If_Present (Ctyp);
+
-- STEP 1a
-- Check that the index range defined by aggregate bounds is
@@ -7931,6 +7942,10 @@ package body Exp_Aggr is
-- NOTE: This sets the global Static_Components to False in most, but
-- not all, cases when it returns False.
+ function Contains_Mutably_Tagged_Component
+ (Typ : Entity_Id) return Boolean;
+ -- Determine if some component of Typ is mutably tagged
+
function Has_Per_Object_Constraint (L : List_Id) return Boolean;
-- Return True if any element of L has Has_Per_Object_Constraint set.
-- L should be the Choices component of an N_Component_Association.
@@ -8433,6 +8448,30 @@ package body Exp_Aggr is
return True;
end Component_OK_For_Backend;
+ ---------------------------------------
+ -- Contains_Mutably_Tagged_Component --
+ ---------------------------------------
+
+ function Contains_Mutably_Tagged_Component
+ (Typ : Entity_Id) return Boolean
+ is
+ Comp : Entity_Id;
+ begin
+ -- Move through Typ's components looking for mutably tagged ones
+
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ -- When we find one, return True
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (Comp)) then
+ return True;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ return False;
+ end Contains_Mutably_Tagged_Component;
+
-------------------------------
-- Has_Per_Object_Constraint --
-------------------------------
@@ -8515,7 +8554,8 @@ package body Exp_Aggr is
end if;
-- If the pragma Aggregate_Individually_Assign is set, always convert to
- -- assignments.
+ -- assignments so that proper tag assignments and conversions can be
+ -- generated.
if Aggregate_Individually_Assign then
Convert_To_Assignments (N, Typ);
@@ -8554,6 +8594,12 @@ package body Exp_Aggr is
Build_Back_End_Aggregate;
end if;
+ -- When we have any components which are mutably tagged types then
+ -- special processing is required.
+
+ elsif Contains_Mutably_Tagged_Component (Typ) then
+ Convert_To_Assignments (N, Typ);
+
-- Gigi doesn't properly handle temporaries of variable size so we
-- generate it in the front-end
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index f03cda62149..3d8b8023988 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -49,6 +49,7 @@ with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
with Lib; use Lib;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -631,8 +632,13 @@ package body Exp_Ch3 is
---------------------------
procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
- Comp_Type : constant Entity_Id := Component_Type (A_Type);
- Comp_Simple_Init : constant Boolean :=
+ -- Obtain the corresponding mutably tagged type's parent subtype to
+ -- handle default initialization.
+
+ Comp_Type : constant Entity_Id :=
+ Get_Corresponding_Tagged_Type_If_Present (Component_Type (A_Type));
+
+ Comp_Simple_Init : constant Boolean :=
Needs_Simple_Initialization
(Typ => Comp_Type,
Consider_IS =>
@@ -1367,6 +1373,7 @@ package body Exp_Ch3 is
return
not (Present (Obj_Id) and then Is_Internal (Obj_Id))
+ and then not Is_Mutably_Tagged_CW_Equivalent_Type (Typ)
and then
Needs_Simple_Initialization
(Typ => Typ,
@@ -3709,7 +3716,11 @@ package body Exp_Ch3 is
(Subtype_Indication (Component_Definition (Decl)), Checks);
Id := Defining_Identifier (Decl);
- Typ := Etype (Id);
+
+ -- Obtain the corresponding mutably tagged type's parent subtype
+ -- to handle default initialization.
+
+ Typ := Get_Corresponding_Tagged_Type_If_Present (Etype (Id));
-- Leave any processing of component requiring late initialization
-- for the second pass.
@@ -4125,7 +4136,11 @@ package body Exp_Ch3 is
while Present (Decl) loop
Comp_Loc := Sloc (Decl);
Id := Defining_Identifier (Decl);
- Typ := Etype (Id);
+
+ -- Obtain the corresponding mutably tagged type's parent
+ -- subtype to handle default initialization.
+
+ Typ := Get_Corresponding_Tagged_Type_If_Present (Etype (Id));
if Initialization_Control.Requires_Late_Init (Decl, Rec_Type)
then
@@ -5407,7 +5422,12 @@ package body Exp_Ch3 is
procedure Expand_Freeze_Array_Type (N : Node_Id) is
Typ : constant Entity_Id := Entity (N);
Base : constant Entity_Id := Base_Type (Typ);
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
+
+ -- Obtain the corresponding mutably tagged type if necessary
+
+ Comp_Typ : constant Entity_Id :=
+ Get_Corresponding_Mutably_Tagged_Type_If_Present
+ (Component_Type (Typ));
begin
if not Is_Bit_Packed_Array (Typ) then
@@ -6436,7 +6456,9 @@ package body Exp_Ch3 is
-- Do not need init for interfaces on virtual targets since they're
-- abstract.
- if Tagged_Type_Expansion or else not Is_Interface (Typ) then
+ if not Is_Mutably_Tagged_CW_Equivalent_Type (Typ)
+ and then (Tagged_Type_Expansion or else not Is_Interface (Typ))
+ then
Build_Record_Init_Proc (Typ_Decl, Typ);
end if;
@@ -6695,6 +6717,29 @@ package body Exp_Ch3 is
end;
end if;
+ -- Handle mutably tagged types by replacing their declarations with
+ -- their class-wide equivalent types.
+
+ declare
+ Comp : Entity_Id;
+ begin
+ if Is_Array_Type (Def_Id) then
+ Comp := First_Entity (Component_Type (Def_Id));
+ else
+ Comp := First_Entity (Def_Id);
+ end if;
+
+ while Present (Comp) loop
+ if Ekind (Etype (Comp)) /= E_Void
+ and then Is_Mutably_Tagged_Type (Etype (Comp))
+ then
+ Set_Etype
+ (Comp, Class_Wide_Equivalent_Type (Etype (Comp)));
+ end if;
+ Next_Entity (Comp);
+ end loop;
+ end;
+
Par_Id := Etype (B_Id);
-- The parent type is private then we need to inherit any TSS operations
@@ -7244,7 +7289,12 @@ package body Exp_Ch3 is
-- Or else build the fully-fledged initialization if need be
- Init_Stmts := Build_Default_Initialization (N, Typ, Def_Id);
+ if Is_Mutably_Tagged_Type (Typ) then
+ Init_Stmts :=
+ Build_Default_Initialization (N, Etype (Typ), Def_Id);
+ else
+ Init_Stmts := Build_Default_Initialization (N, Typ, Def_Id);
+ end if;
-- Insert the whole initialization sequence into the tree. If the
-- object has a delayed freeze, as will be the case when it has
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index bf90b46249a..7349dfc306f 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -47,6 +47,7 @@ with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
with Lib; use Lib;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -4888,10 +4889,17 @@ package body Exp_Ch4 is
Temp := Make_Temporary (Loc, 'P');
- Init_Stmts :=
- Build_Default_Initialization (N, Etyp, Temp,
- For_CW => Is_Class_Wide_Type (Dtyp),
- Target_Ref => Target_Ref);
+ if Is_Mutably_Tagged_Type (Dtyp) then
+ Init_Stmts :=
+ Build_Default_Initialization (N, Etype (Etyp), Temp,
+ For_CW => False,
+ Target_Ref => Target_Ref);
+ else
+ Init_Stmts :=
+ Build_Default_Initialization (N, Etyp, Temp,
+ For_CW => Is_Class_Wide_Type (Dtyp),
+ Target_Ref => Target_Ref);
+ end if;
if Present (Init_Stmts) then
-- We set the allocator as analyzed so that when we analyze
@@ -12743,6 +12751,9 @@ package body Exp_Ch4 is
New_Lhs : Node_Id;
New_Rhs : Node_Id;
Check : Node_Id;
+ Lhs_Sel : Node_Id;
+ Rhs_Sel : Node_Id;
+ C_Typ : Entity_Id := Etype (C);
begin
if First_Time then
@@ -12753,17 +12764,31 @@ package body Exp_Ch4 is
New_Rhs := New_Copy_Tree (Rhs);
end if;
+ Lhs_Sel :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Lhs,
+ Selector_Name => New_Occurrence_Of (C, Loc));
+ Rhs_Sel :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Rhs,
+ Selector_Name => New_Occurrence_Of (C, Loc));
+
+ -- Generate mutably tagged conversions in case we encounter a
+ -- special class-wide equivalent type.
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (C)) then
+ C_Typ := Corresponding_Mutably_Tagged_Type (Etype (C));
+ Make_Mutably_Tagged_Conversion (Lhs_Sel, C_Typ);
+ Make_Mutably_Tagged_Conversion (Rhs_Sel, C_Typ);
+ end if;
+
Check :=
Expand_Composite_Equality
- (Outer_Type => Typ, Nod => Nod, Comp_Type => Etype (C),
- Lhs =>
- Make_Selected_Component (Loc,
- Prefix => New_Lhs,
- Selector_Name => New_Occurrence_Of (C, Loc)),
- Rhs =>
- Make_Selected_Component (Loc,
- Prefix => New_Rhs,
- Selector_Name => New_Occurrence_Of (C, Loc)));
+ (Outer_Type => Typ,
+ Nod => Nod,
+ Comp_Type => C_Typ,
+ Lhs => Lhs_Sel,
+ Rhs => Rhs_Sel);
-- If some (sub)component is an unchecked_union, the whole
-- operation will raise program error.
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index b97e3bb7eee..35c2628fe25 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -41,6 +41,7 @@ with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Inline; use Inline;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -2398,8 +2399,14 @@ package body Exp_Ch5 is
Lhs : constant Node_Id := Name (N);
Loc : constant Source_Ptr := Sloc (N);
Rhs : constant Node_Id := Expression (N);
- Typ : constant Entity_Id := Underlying_Type (Etype (Lhs));
- Exp : Node_Id;
+
+ -- Obtain the relevant corresponding mutably tagged type if necessary
+
+ Typ : constant Entity_Id :=
+ Get_Corresponding_Mutably_Tagged_Type_If_Present
+ (Underlying_Type (Etype (Lhs)));
+
+ Exp : Node_Id;
begin
-- Special case to check right away, if the Componentwise_Assignment
@@ -2776,7 +2783,9 @@ package body Exp_Ch5 is
Apply_Discriminant_Check (Rhs, Typ, Lhs);
end if;
- elsif Is_Array_Type (Typ) and then Is_Constrained (Typ) then
+ elsif Is_Array_Type (Typ) and then
+ (Is_Constrained (Typ) or else Is_Mutably_Tagged_Conversion (Lhs))
+ then
Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
if not Suppress_Assignment_Checks (N) then
@@ -3072,13 +3081,64 @@ package body Exp_Ch5 is
Attribute_Name => Name_Address)));
end if;
- Append_To (L,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => Lhs_Tag,
- Right_Opnd => Rhs_Tag),
- Reason => CE_Tag_Check_Failed));
+ -- Handle assignment to a mutably tagged type
+
+ if Is_Mutably_Tagged_Conversion (Lhs)
+ or else Is_Mutably_Tagged_Type (Typ)
+ or else Is_Mutably_Tagged_Type (Etype (Lhs))
+ then
+ -- Create a tag check when we have the extra
+ -- constrained formal and it is true (meaning we
+ -- are not dealing with a mutably tagged object).
+
+ if Is_Entity_Name (Name (N))
+ and then Is_Formal (Entity (Name (N)))
+ and then Present
+ (Extra_Constrained (Entity (Name (N))))
+ then
+ Append_To (L,
+ Make_If_Statement (Loc,
+ Condition =>
+ New_Occurrence_Of
+ (Extra_Constrained
+ (Entity (Name (N))), Loc),
+ Then_Statements => New_List (
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Lhs_Tag,
+ Right_Opnd => Rhs_Tag),
+ Reason => CE_Tag_Check_Failed))));
+ end if;
+
+ -- Generate a tag assignment before the actual
+ -- assignment so we dispatch to the proper
+ -- assign version.
+
+ Append_To (L,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Lhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag)),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag))));
+
+ -- Otherwise generate a normal tag check
+
+ else
+ Append_To (L,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Lhs_Tag,
+ Right_Opnd => Rhs_Tag),
+ Reason => CE_Tag_Check_Failed));
+ end if;
end;
end if;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 2e873c9c908..da19c031c3d 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -4224,8 +4224,10 @@ package body Exp_Ch6 is
-- because the object has underlying discriminants with defaults.
if Present (Extra_Constrained (Formal)) then
- if Is_Private_Type (Etype (Prev))
- and then not Has_Discriminants (Base_Type (Etype (Prev)))
+ if Is_Mutably_Tagged_Type (Etype (Actual))
+ or else (Is_Private_Type (Etype (Prev))
+ and then not Has_Discriminants
+ (Base_Type (Etype (Prev))))
then
Add_Extra_Actual
(Expr => New_Occurrence_Of (Standard_False, Loc),
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index eacdd17fc4c..e3e9bac2b34 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -8288,6 +8288,9 @@ package body Exp_Ch7 is
if Has_Controlled_Component (Utyp) then
Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
+ elsif Is_Mutably_Tagged_Type (Utyp) then
+ Proc := Find_Prim_Op (Etype (Utyp), Name_Of (Initialize_Case));
+ Check_Visibly_Controlled (Initialize_Case, Etype (Typ), Proc, Ref);
else
Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 58ab557a250..528001ea70a 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -181,22 +181,6 @@ package body Exp_Util is
-- Determine whether pragma Default_Initial_Condition denoted by Prag has
-- an assertion expression that should be verified at run time.
- function Make_CW_Equivalent_Type
- (T : Entity_Id;
- E : Node_Id) return Entity_Id;
- -- T is a class-wide type entity, E is the initial expression node that
- -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
- -- returns the entity of the Equivalent type and inserts on the fly the
- -- necessary declaration such as:
- --
- -- type anon is record
- -- _parent : Root_Type (T); constrained with E discriminants (if any)
- -- Extension : String (1 .. expr to match size of E);
- -- end record;
- --
- -- This record is compatible with any object of the class of T thanks to
- -- the first field and has the same size as E thanks to the second.
-
function Make_Literal_Range
(Loc : Source_Ptr;
Literal_Typ : Entity_Id) return Node_Id;
@@ -10160,13 +10144,13 @@ package body Exp_Util is
-- representation of the extension part.)
function Make_CW_Equivalent_Type
- (T : Entity_Id;
- E : Node_Id) return Entity_Id
+ (T : Entity_Id;
+ E : Node_Id;
+ List_Def : out List_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (E);
Root_Typ : constant Entity_Id := Root_Type (T);
Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ);
- List_Def : constant List_Id := Empty_List;
Comp_List : constant List_Id := New_List;
Equiv_Type : Entity_Id;
@@ -10177,6 +10161,8 @@ package body Exp_Util is
Size_Expr : Node_Id;
begin
+ List_Def := New_List;
+
-- If the root type is already constrained, there are no discriminants
-- in the expression.
@@ -10214,7 +10200,10 @@ package body Exp_Util is
-- need to convert it first to the class-wide type to force a call to
-- the _Size primitive operation.
- if Has_Tag_Of_Type (E) then
+ if No (E) then
+ Size_Attr := Make_Integer_Literal (Loc, RM_Size (T));
+
+ elsif Has_Tag_Of_Type (E) then
if not Has_Discriminants (Etype (E))
or else Is_Constrained (Etype (E))
then
@@ -10237,7 +10226,7 @@ package body Exp_Util is
Attribute_Name => Name_Size);
end if;
- if not Is_Interface (Root_Typ) then
+ if not Is_Interface (Root_Typ) and then Present (E) then
-- subtype rg__xx is
-- Storage_Offset range 1 .. (Exp'size - Typ'object_size)
@@ -10317,11 +10306,15 @@ package body Exp_Util is
Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
- -- A class-wide equivalent type does not require initialization
+ -- A class-wide equivalent type does not require initialization unless
+ -- no expression is present - in which case initialization gets
+ -- generated as part of the mutably tagged type machinery.
- Set_Suppress_Initialization (Equiv_Type);
+ if Present (E) then
+ Set_Suppress_Initialization (Equiv_Type);
+ end if;
- if not Is_Interface (Root_Typ) then
+ if not Is_Interface (Root_Typ) and Present (E) then
Append_To (Comp_List,
Make_Component_Declaration (Loc,
Defining_Identifier =>
@@ -10346,6 +10339,8 @@ package body Exp_Util is
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Tag), Loc))));
+
+ Set_Is_Tag (Defining_Identifier (Last (Comp_List)));
end if;
Append_To (Comp_List,
@@ -10366,17 +10361,6 @@ package body Exp_Util is
Component_Items => Comp_List,
Variant_Part => Empty))));
- -- Suppress all checks during the analysis of the expanded code to avoid
- -- the generation of spurious warnings under ZFP run-time.
-
- Insert_Actions (E, List_Def, Suppress => All_Checks);
-
- -- In the case of an interface type mark the tag for First_Tag_Component
-
- if Is_Interface (Root_Typ) then
- Set_Is_Tag (First_Entity (Equiv_Type));
- end if;
-
return Equiv_Type;
end Make_CW_Equivalent_Type;
@@ -10765,6 +10749,7 @@ package body Exp_Util is
declare
CW_Subtype : constant Entity_Id :=
New_Class_Wide_Subtype (Unc_Typ, E);
+ Equiv_Def : List_Id;
begin
-- A class-wide equivalent type is not needed on VM targets
@@ -10788,7 +10773,14 @@ package body Exp_Util is
end if;
Set_Equivalent_Type
- (CW_Subtype, Make_CW_Equivalent_Type (Unc_Typ, E));
+ (CW_Subtype, Make_CW_Equivalent_Type (Unc_Typ, E, Equiv_Def));
+
+ -- Suppress all checks during the analysis of the expanded
+ -- code to avoid the generation of spurious warnings under
+ -- ZFP run-time.
+
+ Insert_Actions
+ (E, Equiv_Def, Suppress => All_Checks);
end if;
Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 8d64b11d750..16d8e14976c 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -885,6 +885,26 @@ package Exp_Util is
-- list. If Warn is True, a warning will be output at the start of N
-- indicating the deletion of the code.
+ function Make_CW_Equivalent_Type
+ (T : Entity_Id;
+ E : Node_Id;
+ List_Def : out List_Id) return Entity_Id;
+ -- T is a class-wide type entity, and E is the initial expression node that
+ -- constrains T in cases such as: " X: T := E" or "new T'(E)". When there
+ -- is no E present then it is assumed that T is an unconstrained mutably
+ -- tagged class-wide type.
+ --
+ -- This function returns the entity of the Equivalent type and inserts
+ -- on the fly the necessary declaration into List_Def such as:
+ --
+ -- type anon is record
+ -- _parent : Root_Type (T); constrained with E discriminants (if any)
+ -- Extension : String (1 .. expr to match size of E);
+ -- end record;
+ --
+ -- This record is compatible with any object of the class of T thanks to
+ -- the first field and has the same size as E thanks to the second.
+
function Make_Invariant_Call (Expr : Node_Id) return Node_Id;
-- Generate a call to the Invariant_Procedure associated with the type of
-- expression Expr. Expr is passed as an actual parameter in the call.
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 523b026cc21..5dbf7198cb4 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1012,15 +1012,10 @@ package body Freeze is
elsif Is_Record_Type (T) then
- -- A class-wide type is never considered to have a known size
-
- if Is_Class_Wide_Type (T) then
- return False;
-
-- A subtype of a variant record must not have non-static
-- discriminated components.
- elsif T /= Base_Type (T)
+ if T /= Base_Type (T)
and then not Static_Discriminated_Components (T)
then
return False;
@@ -7819,6 +7814,7 @@ package body Freeze is
if (Has_Size_Clause (E) or else Has_Object_Size_Clause (E))
and then not Size_Known_At_Compile_Time (E)
+ and then not Is_Mutably_Tagged_Type (E)
then
-- Suppress this message if errors posted on E, even if we are
-- in all errors mode, since this is often a junk message
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index 3cbbf5042f1..ebf1f70de78 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -376,6 +376,7 @@ GNAT_ADA_OBJS = \
ada/namet.o \
ada/nlists.o \
ada/nmake.o \
+ ada/mutably_tagged.o \
ada/opt.o \
ada/osint-c.o \
ada/osint.o \
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 54a5703d1a5..5aa246d1fb6 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -460,6 +460,7 @@ package Gen_IL.Fields is
Class_Postconditions,
Class_Preconditions,
Class_Preconditions_Subprogram,
+ Class_Wide_Equivalent_Type,
Class_Wide_Type,
Cloned_Subtype,
Component_Alignment,
@@ -744,6 +745,7 @@ package Gen_IL.Fields is
Is_Local_Anonymous_Access,
Is_Loop_Parameter,
Is_Machine_Code_Subprogram,
+ Is_Mutably_Tagged_Type,
Is_Non_Static_Subtype,
Is_Null_Init_Proc,
Is_Obsolescent,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index f5b1b434e42..c3595bb3dd6 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -459,6 +459,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Associated_Node_For_Itype, Node_Id),
Sm (Can_Use_Internal_Rep, Flag, Base_Type_Only,
Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"),
+ Sm (Class_Wide_Equivalent_Type, Node_Id),
Sm (Class_Wide_Type, Node_Id),
Sm (Contract, Node_Id),
Sm (Current_Use_Clause, Node_Id),
@@ -504,6 +505,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Is_Fixed_Lower_Bound_Array_Subtype, Flag),
Sm (Is_Fixed_Lower_Bound_Index_Subtype, Flag),
Sm (Is_Generic_Actual_Type, Flag),
+ Sm (Is_Mutably_Tagged_Type, Flag),
Sm (Is_Non_Static_Subtype, Flag),
Sm (Is_Private_Composite, Flag),
Sm (Is_RACW_Stub_Type, Flag),
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 2764ebdaf04..4dfb896e42f 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -904,6 +904,7 @@ Experimental Language Extensions
* Pragma Storage_Model::
* Simpler accessibility model::
* Case pattern matching::
+* Mutably Tagged Types with Size’Class Aspect::
Security Hardening Features
@@ -29228,6 +29229,7 @@ particular the @code{Shift_Left} and @code{Shift_Right} intrinsics.
* Pragma Storage_Model::
* Simpler accessibility model::
* Case pattern matching::
+* Mutably Tagged Types with Size’Class Aspect::
@end menu
@@ -29259,7 +29261,7 @@ while removing dynamic accessibility checking.
Here is a link to the full RFC:
@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-simpler-accessibility.md}
-@node Case pattern matching,,Simpler accessibility model,Experimental Language Extensions
+@node Case pattern matching,Mutably Tagged Types with Size’Class Aspect,Simpler accessibility model,Experimental Language Extensions
@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{44b}
@subsection Case pattern matching
@@ -29391,8 +29393,48 @@ case statement with composite selector type”.
Link to the original RFC:
@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-pattern-matching.rst}
+@node Mutably Tagged Types with Size’Class Aspect,,Case pattern matching,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{44c}
+@subsection Mutably Tagged Types with Size’Class Aspect
+
+
+The @cite{Size’Class} aspect can be applied to a tagged type to specify a size
+constraint for the type and its descendants. When this aspect is specified
+on a tagged type, the class-wide type of that type is considered to be a
+“mutably tagged” type - meaning that objects of the class-wide type can have
+their tag changed by assignment from objects with a different tag.
+
+When the aspect is applied to a type, the size of each of its descendant types
+must not exceed the size specified for the aspect.
+
+Example:
+
+@example
+type Base is tagged null record
+ with Size'Class => 16 * 8; -- Size in bits (128 bits, or 16 bytes)
+
+type Derived_Type is new Base with record
+ Data_Field : Integer;
+end record; -- ERROR if Derived_Type exceeds 16 bytes
+@end example
+
+Class-wide types with a specified @cite{Size’Class} can be used as the type of
+array components, record components, and stand-alone objects.
+
+@example
+Inst : Base'Class;
+type Array_of_Base is array (Positive range <>) of Base'Class;
+@end example
+
+Note: Legality of the @cite{Size’Class} aspect is subject to certain restrictions on
+the tagged type, such as being undiscriminated, having no dynamic composite
+subcomponents, among others detailed in the RFC.
+
+Link to the original RFC:
+@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/topic/rfc-finally/considered/rfc-class-size.md}
+
@node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top
-@anchor{gnat_rm/security_hardening_features doc}@anchor{44c}@anchor{gnat_rm/security_hardening_features id1}@anchor{44d}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15}
+@anchor{gnat_rm/security_hardening_features doc}@anchor{44d}@anchor{gnat_rm/security_hardening_features id1}@anchor{44e}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15}
@chapter Security Hardening Features
@@ -29414,7 +29456,7 @@ change.
@end menu
@node Register Scrubbing,Stack Scrubbing,,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{44e}
+@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{44f}
@section Register Scrubbing
@@ -29450,7 +29492,7 @@ programming languages, see @cite{Using the GNU Compiler Collection (GCC)}.
@c Stack Scrubbing:
@node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{44f}
+@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{450}
@section Stack Scrubbing
@@ -29594,7 +29636,7 @@ Bar_Callable_Ptr.
@c Hardened Conditionals:
@node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{450}
+@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{451}
@section Hardened Conditionals
@@ -29684,7 +29726,7 @@ be used with other programming languages supported by GCC.
@c Hardened Booleans:
@node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{451}
+@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{452}
@section Hardened Booleans
@@ -29745,7 +29787,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection
@c Control Flow Redundancy:
@node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{452}
+@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{453}
@section Control Flow Redundancy
@@ -29913,7 +29955,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}. These options
can be used with other programming languages supported by GCC.
@node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top
-@anchor{gnat_rm/obsolescent_features doc}@anchor{453}@anchor{gnat_rm/obsolescent_features id1}@anchor{454}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16}
+@anchor{gnat_rm/obsolescent_features doc}@anchor{454}@anchor{gnat_rm/obsolescent_features id1}@anchor{455}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16}
@chapter Obsolescent Features
@@ -29932,7 +29974,7 @@ compatibility purposes.
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id2}@anchor{455}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{456}
+@anchor{gnat_rm/obsolescent_features id2}@anchor{456}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{457}
@section pragma No_Run_Time
@@ -29945,7 +29987,7 @@ preferred usage is to use an appropriately configured run-time that
includes just those features that are to be made accessible.
@node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id3}@anchor{457}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{458}
+@anchor{gnat_rm/obsolescent_features id3}@anchor{458}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{459}
@section pragma Ravenscar
@@ -29954,7 +29996,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma
is part of the new Ada 2005 standard.
@node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id4}@anchor{459}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{45a}
+@anchor{gnat_rm/obsolescent_features id4}@anchor{45a}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{45b}
@section pragma Restricted_Run_Time
@@ -29964,7 +30006,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for
this kind of implementation dependent addition.
@node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id5}@anchor{45b}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{45c}
+@anchor{gnat_rm/obsolescent_features id5}@anchor{45c}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{45d}
@section pragma Task_Info
@@ -29990,7 +30032,7 @@ in the spec of package System.Task_Info in the runtime
library.
@node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{45d}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{45e}
+@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{45e}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{45f}
@section package System.Task_Info (@code{s-tasinf.ads})
@@ -30000,7 +30042,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package
standard replacement for GNAT’s @code{Task_Info} functionality.
@node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top
-@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{45f}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{460}
+@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{460}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{461}
@chapter Compatibility and Porting Guide
@@ -30022,7 +30064,7 @@ applications developed in other Ada environments.
@end menu
@node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{461}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{462}
+@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{462}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{463}
@section Writing Portable Fixed-Point Declarations
@@ -30144,7 +30186,7 @@ If you follow this scheme you will be guaranteed that your fixed-point
types will be portable.
@node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{463}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{464}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{464}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{465}
@section Compatibility with Ada 83
@@ -30172,7 +30214,7 @@ following subsections treat the most likely issues to be encountered.
@end menu
@node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{465}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{466}
+@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{466}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{467}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@@ -30272,7 +30314,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration.
@end itemize
@node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{467}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{468}
+@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{468}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{469}
@subsection More deterministic semantics
@@ -30300,7 +30342,7 @@ which open select branches are executed.
@end itemize
@node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{469}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{46a}
+@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{46a}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{46b}
@subsection Changed semantics
@@ -30342,7 +30384,7 @@ covers only the restricted range.
@end itemize
@node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{46b}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{46c}
+@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{46c}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{46d}
@subsection Other language compatibility issues
@@ -30375,7 +30417,7 @@ include @code{pragma Interface} and the floating point type attributes
@end itemize
@node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{46d}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{46e}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{46e}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{46f}
@section Compatibility between Ada 95 and Ada 2005
@@ -30447,7 +30489,7 @@ can declare a function returning a value from an anonymous access type.
@end itemize
@node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{46f}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{470}
+@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{470}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{471}
@section Implementation-dependent characteristics
@@ -30470,7 +30512,7 @@ transition from certain Ada 83 compilers.
@end menu
@node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{471}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{472}
+@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{472}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{473}
@subsection Implementation-defined pragmas
@@ -30492,7 +30534,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not
relevant in a GNAT context and hence are not otherwise implemented.
@node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{473}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{474}
+@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{474}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{475}
@subsection Implementation-defined attributes
@@ -30506,7 +30548,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and
@code{Type_Class}.
@node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{475}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{476}
+@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{476}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{477}
@subsection Libraries
@@ -30535,7 +30577,7 @@ be preferable to retrofit the application using modular types.
@end itemize
@node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{477}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{478}
+@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{478}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{479}
@subsection Elaboration order
@@ -30571,7 +30613,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally
@end itemize
@node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{479}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{47a}
+@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{47a}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{47b}
@subsection Target-specific aspects
@@ -30584,10 +30626,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus
Ada 2005 and Ada 2012) are sometimes
incompatible with typical Ada 83 compiler practices regarding implicit
packing, the meaning of the Size attribute, and the size of access values.
-GNAT’s approach to these issues is described in @ref{47b,,Representation Clauses}.
+GNAT’s approach to these issues is described in @ref{47c,,Representation Clauses}.
@node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{47c}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{47d}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{47d}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{47e}
@section Compatibility with Other Ada Systems
@@ -30630,7 +30672,7 @@ far beyond this minimal set, as described in the next section.
@end itemize
@node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{47e}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{47b}
+@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{47f}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{47c}
@section Representation Clauses
@@ -30723,7 +30765,7 @@ with thin pointers.
@end itemize
@node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{47f}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{480}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{480}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{481}
@section Compatibility with HP Ada 83
@@ -30753,7 +30795,7 @@ extension of package System.
@end itemize
@node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top
-@anchor{share/gnu_free_documentation_license doc}@anchor{481}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{482}
+@anchor{share/gnu_free_documentation_license doc}@anchor{482}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{483}
@chapter GNU Free Documentation License
diff --git a/gcc/ada/mutably_tagged.adb b/gcc/ada/mutably_tagged.adb
new file mode 100644
index 00000000000..34b032f08c8
--- /dev/null
+++ b/gcc/ada/mutably_tagged.adb
@@ -0,0 +1,337 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M U T A B L Y _ T A G G E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2024-2024, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Casing; use Casing;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Exp_Util; use Exp_Util;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Rtsfind; use Rtsfind;
+with Snames; use Snames;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+
+package body Mutably_Tagged is
+
+ ---------------------------------------
+ -- Corresponding_Mutably_Tagged_Type --
+ ---------------------------------------
+
+ function Corresponding_Mutably_Tagged_Type
+ (CW_Equiv_Typ : Entity_Id) return Entity_Id
+ is
+ begin
+ return Class_Wide_Type (Parent_Subtype (CW_Equiv_Typ));
+ end Corresponding_Mutably_Tagged_Type;
+
+ ----------------------------------------
+ -- Depends_On_Mutably_Tagged_Ext_Comp --
+ ----------------------------------------
+
+ function Depends_On_Mutably_Tagged_Ext_Comp (N : Node_Id) return Boolean is
+ Typ : Entity_Id;
+ Typ_Comp : Entity_Id;
+ Curr : Node_Id;
+ Prev : Node_Id;
+ begin
+ -- Move through each prefix until we hit a type conversion from a
+ -- mutably tagged type then check if the referenced component exists in
+ -- the root type or an extension.
+
+ Curr := N;
+ while Has_Prefix (Curr) loop
+ Prev := Curr;
+ Curr := Prefix (Curr);
+
+ -- Find a prefix which is a type conversion from a mutably tagged
+ -- type in some form - either class-wide equivalent type or
+ -- directly a mutably tagged type.
+
+ if Nkind (Curr) in N_Unchecked_Type_Conversion
+ | N_Type_Conversion
+ and then (Is_Mutably_Tagged_CW_Equivalent_Type
+ (Etype (Expression (Curr)))
+ or else Is_Mutably_Tagged_Type
+ (Etype (Expression (Curr))))
+
+ -- Verify that the prefix references a component
+
+ and then Is_Entity_Name (Selector_Name (Prev))
+ and then Ekind (Entity (Selector_Name (Prev)))
+ = E_Component
+ then
+ -- Obtain the root type
+
+ Typ := Etype (if Is_Mutably_Tagged_Type
+ (Etype (Expression (Curr)))
+ then
+ Etype (Expression (Curr))
+ else
+ Corresponding_Mutably_Tagged_Type
+ (Etype (Expression (Curr))));
+
+ -- Move through the components of the root type looking for a
+ -- match to the reference component.
+
+ Typ_Comp := First_Component (Typ);
+ while Present (Typ_Comp) loop
+
+ -- When there is a match we know the component reference
+ -- doesn't depend on a type extension.
+
+ if Chars (Typ_Comp) = Chars (Entity (Selector_Name (Prev))) then
+ return False;
+ end if;
+
+ Next_Component (Typ_Comp);
+ end loop;
+
+ -- Otherwise, the component must depend on an extension
+
+ return True;
+ end if;
+ end loop;
+
+ -- If we get here then we know we don't have any sort of relevant type
+ -- conversion from a mutably tagged object.
+
+ return False;
+ end Depends_On_Mutably_Tagged_Ext_Comp;
+
+ ------------------------------------------------------
+ -- Get_Corresponding_Mutably_Tagged_Type_If_Present --
+ ------------------------------------------------------
+
+ function Get_Corresponding_Mutably_Tagged_Type_If_Present
+ (Typ : Entity_Id) return Entity_Id
+ is
+ begin
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Typ) then
+ return Corresponding_Mutably_Tagged_Type (Typ);
+ end if;
+
+ return Typ;
+ end Get_Corresponding_Mutably_Tagged_Type_If_Present;
+
+ ----------------------------------------------
+ -- Get_Corresponding_Tagged_Type_If_Present --
+ ----------------------------------------------
+
+ function Get_Corresponding_Tagged_Type_If_Present
+ (Typ : Entity_Id) return Entity_Id
+ is
+ begin
+ -- Obtain the related tagged type for the class-wide mutably
+ -- tagged type associated with the class-wide equivalent type.
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Typ) then
+ return Parent_Subtype (Typ);
+ end if;
+
+ return Typ;
+ end Get_Corresponding_Tagged_Type_If_Present;
+
+ ----------------------------------
+ -- Is_Mutably_Tagged_Conversion --
+ ----------------------------------
+
+ function Is_Mutably_Tagged_Conversion (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Unchecked_Type_Conversion
+ and then Is_Mutably_Tagged_CW_Equivalent_Type
+ (Etype (Expression (N)));
+ end Is_Mutably_Tagged_Conversion;
+
+ ------------------------------------------
+ -- Is_Mutably_Tagged_CW_Equivalent_Type --
+ ------------------------------------------
+
+ function Is_Mutably_Tagged_CW_Equivalent_Type
+ (Typ : Entity_Id) return Boolean
+ is
+ begin
+ -- First assure Typ is OK to test since this function can be called in
+ -- a context where analysis failed.
+
+ return Present (Typ)
+ and then not Error_Posted (Typ)
+
+ -- Finally check Typ is a class-wide equivalent type which has an
+ -- associated mutably tagged class-wide type (e.g. it is a class-wide
+ -- type with a size clause).
+
+ and then Is_Class_Wide_Equivalent_Type (Typ)
+ and then Present (Parent_Subtype (Typ))
+ and then Present (Class_Wide_Type (Parent_Subtype (Typ)))
+ and then Has_Size_Clause (Corresponding_Mutably_Tagged_Type (Typ));
+ end Is_Mutably_Tagged_CW_Equivalent_Type;
+
+ --------------------------------
+ -- Make_CW_Size_Compile_Check --
+ --------------------------------
+
+ function Make_CW_Size_Compile_Check
+ (New_Typ : Entity_Id;
+ Mut_Tag_Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (New_Typ);
+ begin
+ -- Generate a string literal for New_Typ's name which is needed for
+ -- printing within the Compile_Time_Error.
+
+ Get_Decoded_Name_String (Chars (New_Typ));
+ Set_Casing (Mixed_Case);
+
+ -- Build a pragma Compile_Time_Error to force the backend to
+ -- preform appropriate sizing checks.
+
+ -- Generate:
+ -- pragma Compile_Time_Error
+ -- (New_Typ'Size < Mut_Tag_Typ'Size,
+ -- "class size for by-reference type ""New_Typ"" too small")
+
+ return
+ Make_Pragma (Loc,
+ Chars => Name_Compile_Time_Error,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => (
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Size,
+ Prefix =>
+ New_Occurrence_Of (New_Typ, Loc)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ RM_Size (Mut_Tag_Typ))))),
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+
+ -- Is it possible to print the size of New_Typ via
+ -- Validate_Compile_Time_Warning_Or_Error after the back-end
+ -- has run to generate the error message manually ???
+
+ Make_String_Literal (Loc,
+ "class size for by-reference type """
+ & To_String (String_From_Name_Buffer)
+ & """ too small"))));
+ end Make_CW_Size_Compile_Check;
+
+ ------------------------------------
+ -- Make_Mutably_Tagged_Conversion --
+ ------------------------------------
+
+ procedure Make_Mutably_Tagged_Conversion
+ (N : Node_Id;
+ Typ : Entity_Id := Empty;
+ Force : Boolean := False)
+ is
+ Conv_Typ : constant Entity_Id :=
+
+ -- When Typ is not present, we obtain it at this point
+
+ (if Present (Typ) then
+ Typ
+ else
+ Corresponding_Mutably_Tagged_Type (Etype (N)));
+
+ begin
+ -- Allow "forcing" the rewrite to an unchecked conversion
+
+ if Force
+
+ -- Otherwise, don't make the conversion when N is on the left-hand
+ -- side of the assignment, is already part of an unchecked conversion,
+ -- or is part of a renaming.
+
+ or else (not Known_To_Be_Assigned (N, Only_LHS => True)
+ and then (No (Parent (N))
+ or else Nkind (Parent (N))
+ not in N_Selected_Component
+ | N_Unchecked_Type_Conversion
+ | N_Object_Renaming_Declaration))
+ then
+ -- Exclude the case where we have a 'Size so that we get the proper
+ -- size of the class-wide equivalent type. Are there other cases ???
+
+ if Present (Parent (N))
+ and then Nkind (Parent (N)) = N_Attribute_Reference
+ and then Attribute_Name (Parent (N)) in Name_Size
+ then
+ return;
+ end if;
+
+ -- Create the conversion
+
+ Rewrite (N,
+ Unchecked_Convert_To
+ (Conv_Typ, Relocate_Node (N)));
+ end if;
+ end Make_Mutably_Tagged_Conversion;
+
+ ----------------------------------
+ -- Make_Mutably_Tagged_CW_Check --
+ ----------------------------------
+
+ function Make_Mutably_Tagged_CW_Check
+ (N : Node_Id;
+ Tag : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ -- Displace the pointer to the base of the objects applying 'Address,
+ -- which is later expanded into a call to RE_Base_Address.
+
+ N_Tag : constant Node_Id :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (N),
+ Attribute_Name => Name_Address)));
+ begin
+ -- Generate the runtime call to test class-wide membership
+
+ return
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Tag_Check_Failed,
+ Condition =>
+ Make_Op_Not (Loc,
+ Make_Function_Call (Loc,
+ Parameter_Associations => New_List (N_Tag, Tag),
+ Name =>
+ New_Occurrence_Of (RTE (RE_CW_Membership), Loc))));
+ end Make_Mutably_Tagged_CW_Check;
+
+end Mutably_Tagged;
diff --git a/gcc/ada/mutably_tagged.ads b/gcc/ada/mutably_tagged.ads
new file mode 100644
index 00000000000..b1e393f98ad
--- /dev/null
+++ b/gcc/ada/mutably_tagged.ads
@@ -0,0 +1,120 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M U T A B L Y _ T A G G E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2024-2024, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Semantic and expansion utility routines dealing with mutably tagged types
+
+with Types; use Types;
+
+package Mutably_Tagged is
+
+ --------------------------------------------
+ -- Implementation of Mutably Tagged Types --
+ --------------------------------------------
+
+ -- This package implements mutably tagged types via the Size'class aspect
+ -- which enables the creation of class-wide types with a specific maximum
+ -- size. This allows such types to be used directly in record components,
+ -- in object declarations without an initial expression, and to be
+ -- assigned a value from any type in a mutably tagged type's hierarchy.
+
+ -- For example, this structure allows Base_Type and its derivatives to be
+ -- treated as components with a predictable size:
+
+ -- type Base_Type is tagged null record
+ -- with Size'Class => 128;
+
+ -- type Container is record
+ -- Component : Base_Type'Class;
+ -- end record;
+
+ -- The core of thier implementation involve creating an "equivalent" type
+ -- for each class-wide type that adheres to the Size'Class constraint. This
+ -- is achieved using the function Make_CW_Equivalent_Type, which
+ -- generates a type that is compatible in size and structure with any
+ -- derived type of the base class-wide type.
+
+ -- Once the class-wide equivalent type is generated, all references to
+ -- mutably tagged typed object declarations get rewritten to be
+ -- declarations of said equivalent type. References to these objects also
+ -- then get wrapped in unchecked conversions to the proper mutably tagged
+ -- class-wide type.
+
+ function Corresponding_Mutably_Tagged_Type
+ (CW_Equiv_Typ : Entity_Id) return Entity_Id;
+ -- Given a class-wide equivalent type obtain the related mutably tagged
+ -- class-wide type.
+
+ function Depends_On_Mutably_Tagged_Ext_Comp (N : Node_Id) return Boolean;
+ -- Return true if the given node N contains a reference to a component
+ -- of a mutably tagged object which comes from a type extension.
+
+ function Get_Corresponding_Mutably_Tagged_Type_If_Present
+ (Typ : Entity_Id) return Entity_Id;
+ -- Obtain the corresponding mutably tagged type associated with Typ when
+ -- Typ is a mutably tagged class-wide equivalent type. Otherwise, just
+ -- return Typ.
+
+ function Get_Corresponding_Tagged_Type_If_Present
+ (Typ : Entity_Id) return Entity_Id;
+ -- Obtain the corresponding tag type associated with Typ when
+ -- Typ is a mutably tagged class-wide equivalent type. Otherwise, Just
+ -- return Typ.
+
+ -- This function is mostly used when we need a concrete type to generate
+ -- initialization for mutably tagged types.
+
+ function Is_Mutably_Tagged_Conversion (N : Node_Id) return Boolean;
+ -- Return True if expression N is an object of a mutably tagged class-wide
+ -- equivalent type which has been expanded into a type conversion to
+ -- its related mutably tagged class-wide type.
+
+ function Is_Mutably_Tagged_CW_Equivalent_Type
+ (Typ : Entity_Id) return Boolean;
+ -- Determine if Typ is a class-wide equivalent type
+
+ procedure Make_Mutably_Tagged_Conversion
+ (N : Node_Id;
+ Typ : Entity_Id := Empty;
+ Force : Boolean := False);
+ -- Expand a reference N to a given mutably tagged type Typ. When Typ is not
+ -- present the closest associated mutably tagged type in the hierarchy is
+ -- used.
+
+ -- Force is used to ignore certain predicates which avoid generating the
+ -- conversion (e.g. when N is on the left-hand side of an assignment).
+
+ function Make_CW_Size_Compile_Check
+ (New_Typ : Entity_Id;
+ Mut_Tag_Typ : Entity_Id) return Node_Id;
+ -- Generate a type size check on New_Typ based on the size set in
+ -- the mutably tagged type Mut_Tag_Typ.
+
+ function Make_Mutably_Tagged_CW_Check
+ (N : Node_Id;
+ Tag : Node_Id) return Node_Id;
+ -- Generate class-wide membership test for a given expression N based on
+ -- Tag.
+
+end Mutably_Tagged;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 249350d21de..1dbde1fae31 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -37,6 +37,7 @@ with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Namet.Sp; use Namet.Sp;
with Nmake; use Nmake;
@@ -2699,7 +2700,18 @@ package body Sem_Aggr is
Full_Analysis := Save_Analysis;
Expander_Mode_Restore;
- if Is_Tagged_Type (Etype (Expr)) then
+ -- Skip tagged checking for mutably tagged CW equivalent
+ -- types.
+
+ if Is_Tagged_Type (Etype (Expr))
+ and then Is_Class_Wide_Equivalent_Type
+ (Component_Type (Etype (N)))
+ then
+ null;
+
+ -- Otherwise perform the dynamic tag check
+
+ elsif Is_Tagged_Type (Etype (Expr)) then
Check_Dynamically_Tagged_Expression
(Expr => Expr,
Typ => Component_Type (Etype (N)),
@@ -5344,6 +5356,12 @@ package body Sem_Aggr is
Relocate := True;
end if;
+ -- Obtain the corresponding mutably tagged types if we are looking
+ -- at a special internally generated class-wide equivalent type.
+
+ Expr_Type :=
+ Get_Corresponding_Mutably_Tagged_Type_If_Present (Expr_Type);
+
Analyze_And_Resolve (Expr, Expr_Type);
Check_Expr_OK_In_Limited_Aggregate (Expr);
Check_Non_Static_Context (Expr);
@@ -5351,7 +5369,9 @@ package body Sem_Aggr is
-- Check wrong use of class-wide types
- if Is_Class_Wide_Type (Etype (Expr)) then
+ if Is_Class_Wide_Type (Etype (Expr))
+ and then not Is_Mutably_Tagged_Type (Expr_Type)
+ then
Error_Msg_N ("dynamically tagged expression not allowed", Expr);
end if;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2563a92f2f0..9c3bc62d321 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -46,6 +46,7 @@ with Gnatvsn; use Gnatvsn;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
+with Mutably_Tagged; use Mutably_Tagged;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
@@ -6753,7 +6754,10 @@ package body Sem_Attr is
Check_E0;
Check_Dereference;
- if not Is_Tagged_Type (P_Type) then
+ if Is_Mutably_Tagged_CW_Equivalent_Type (P_Type) then
+ null;
+
+ elsif not Is_Tagged_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be tagged");
-- Next test does not apply to generated code why not, and what does
@@ -11785,6 +11789,10 @@ package body Sem_Attr is
Error_Msg_F
("illegal attribute for discriminant-dependent component",
P);
+
+ elsif Depends_On_Mutably_Tagged_Ext_Comp (P) then
+ Error_Msg_F
+ ("illegal attribute for mutably tagged component", P);
end if;
-- Check static matching rule of 3.10.2(27). Nominal subtype
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 93e81fd9539..d05c7b61194 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -40,6 +40,7 @@ with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref;
+with Mutably_Tagged; use Mutably_Tagged;
with Nlists; use Nlists;
with Namet; use Namet;
with Nmake; use Nmake;
@@ -11497,6 +11498,10 @@ package body Sem_Ch12 is
Error_Msg_N
("illegal discriminant-dependent component for in out parameter",
Actual);
+ elsif Depends_On_Mutably_Tagged_Ext_Comp (Actual) then
+ Error_Msg_N
+ ("illegal mutably tagged component for in out parameter",
+ Actual);
end if;
-- The actual has to be resolved in order to check that it is a
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index caebe2e793e..2fbddf3f952 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -43,6 +43,7 @@ with Freeze; use Freeze;
with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -3069,6 +3070,15 @@ package body Sem_Ch13 is
end if;
end if;
+ -- Propagate the 'Size'Class aspect to the class-wide type
+
+ if A_Id = Aspect_Size and then Class_Present (Aspect) then
+ Ent :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Ent,
+ Attribute_Name => Name_Class);
+ end if;
+
-- Construct the attribute_definition_clause. The expression
-- in the aspect specification is simply shared with the
-- constructed attribute, because it will be fully analyzed
@@ -7337,6 +7347,70 @@ package body Sem_Ch13 is
& "supported", N);
end if;
+ -- Handle extension aspect 'Size'Class which allows for
+ -- "mutably tagged" types.
+
+ if Ekind (Etyp) = E_Class_Wide_Type then
+ Error_Msg_GNAT_Extension
+ ("attribute size class", Sloc (N));
+
+ -- Check for various restrictions applied to mutably
+ -- tagged types.
+
+ if Is_Derived_Type (Etype (Etyp)) then
+ Error_Msg_N
+ ("cannot be specified on derived types", Nam);
+
+ elsif Ekind (Etype (Prefix (Nam))) = E_Record_Subtype then
+ Error_Msg_N
+ ("cannot be specified on a subtype", Nam);
+
+ elsif Is_Interface (Etype (Etyp)) then
+ Error_Msg_N
+ ("cannot be specified on interface types", Nam);
+
+ elsif Has_Discriminants (Etype (Etyp)) then
+ Error_Msg_N
+ ("cannot be specified on discriminated type", Nam);
+
+ elsif Present (Incomplete_Or_Partial_View (Etype (Etyp)))
+ and then Is_Tagged_Type
+ (Incomplete_Or_Partial_View (Etype (Etyp)))
+ then
+ Error_Msg_N
+ ("cannot be specified on a type whose partial view"
+ & " is tagged", Nam);
+
+ -- Otherwise, the declaration is valid
+
+ else
+ declare
+ Actions : List_Id;
+ begin
+ -- Generate our class-wide equivalent type which
+ -- is sized according to the value specified by
+ -- 'Size'Class.
+
+ Set_Class_Wide_Equivalent_Type (Etyp,
+ Make_CW_Equivalent_Type (Etyp, Empty, Actions));
+
+ -- Add a Compile_Time_Error sizing check as a hint
+ -- to the backend.
+
+ Append_To (Actions,
+ Make_CW_Size_Compile_Check
+ (Etype (Etyp), U_Ent));
+
+ -- Set the expansion to occur during freezing when
+ -- everything is analyzed
+
+ Append_Freeze_Actions (Etyp, Actions);
+
+ Set_Is_Mutably_Tagged_Type (Etyp);
+ end;
+ end if;
+ end if;
+
Set_Has_Size_Clause (U_Ent);
end;
end if;
diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb
index db17023db28..aae9990eb4d 100644
--- a/gcc/ada/sem_ch2.adb
+++ b/gcc/ada/sem_ch2.adb
@@ -27,6 +27,7 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Einfo.Utils; use Einfo.Utils;
with Ghost; use Ghost;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
@@ -81,6 +82,12 @@ package body Sem_Ch2 is
Find_Direct_Name (N);
end if;
+ -- Generate a conversion when we see an expanded mutably tagged type
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (N)) then
+ Make_Mutably_Tagged_Conversion (N);
+ end if;
+
-- A Ghost entity must appear in a specific context. Only do this
-- checking on non-overloaded expressions, as otherwise we need to
-- wait for resolution, and the checking is done in Resolve_Entity_Name.
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 633e1367aee..76e5cdcbf5d 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -48,6 +48,7 @@ with Itypes; use Itypes;
with Layout; use Layout;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -2162,6 +2163,7 @@ package body Sem_Ch3 is
-- and thus unconstrained. Regular components must be constrained.
if not Is_Definite_Subtype (T)
+ and then not Is_Mutably_Tagged_Type (T)
and then Chars (Id) /= Name_uParent
then
if Is_Class_Wide_Type (T) then
@@ -4802,8 +4804,30 @@ package body Sem_Ch3 is
null;
elsif Is_Class_Wide_Type (T) then
- Error_Msg_N
- ("initialization required in class-wide declaration", N);
+
+ -- Case of a mutably tagged type
+
+ if Is_Mutably_Tagged_Type (T) then
+ Act_T := Class_Wide_Equivalent_Type (T);
+
+ Rewrite (Object_Definition (N),
+ New_Occurrence_Of (Act_T, Loc));
+
+ Insert_After (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Init_Proc (Etype (T)), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To
+ (Etype (T), New_Occurrence_Of (Id, Loc)))));
+
+ Freeze_Before (N, Act_T);
+
+ -- Otherwise an initial expression is required
+
+ else
+ Error_Msg_N
+ ("initialization required in class-wide declaration", N);
+ end if;
else
Error_Msg_N
@@ -4900,6 +4924,17 @@ package body Sem_Ch3 is
goto Leave;
end if;
+ -- Rewrite mutably tagged class-wide type declarations to be that
+ -- of the corresponding class-wide equivalent type.
+
+ elsif Is_Mutably_Tagged_Type (T) then
+ Act_T := Class_Wide_Equivalent_Type (T);
+
+ Rewrite (Object_Definition (N),
+ New_Occurrence_Of (Act_T, Loc));
+
+ Freeze_Before (N, Act_T);
+
else
-- Ensure that the generated subtype has a unique external name
-- when the related object is public. This guarantees that the
@@ -6679,7 +6714,11 @@ package body Sem_Ch3 is
-- that all the indexes are unconstrained but we still need to make sure
-- that the element type is constrained.
- if not Is_Definite_Subtype (Element_Type) then
+ if Is_Mutably_Tagged_Type (Element_Type) then
+ Set_Component_Type (T,
+ Class_Wide_Equivalent_Type (Element_Type));
+
+ elsif not Is_Definite_Subtype (Element_Type) then
Error_Msg_N
("unconstrained element type in array declaration",
Subtype_Indication (Component_Def));
@@ -17774,6 +17813,83 @@ package body Sem_Ch3 is
Build_Derived_Type (N, Parent_Type, T, Is_Completion,
Derive_Subps => not Is_Underlying_Record_View (T));
+ -- Check for special mutably tagged type declarations
+
+ if Is_Tagged_Type (Parent_Type)
+ and then not Error_Posted (T)
+ then
+ declare
+ Actions : List_Id;
+ CW_Typ : constant Entity_Id := Class_Wide_Type (T);
+ Root_Class_Typ : constant Entity_Id :=
+ Class_Wide_Type (Root_Type (Parent_Type));
+ begin
+ -- Perform various checks when we are indeed looking at a
+ -- mutably tagged declaration.
+
+ if Present (Root_Class_Typ)
+ and then Is_Mutably_Tagged_Type (Root_Class_Typ)
+ then
+ -- Verify the level of the descendant's declaration is not
+ -- deeper than the root type since this could cause leaking
+ -- of the type.
+
+ if Scope (Root_Class_Typ) /= Scope (T)
+ and then Deepest_Type_Access_Level (Root_Class_Typ)
+ < Deepest_Type_Access_Level (T)
+ then
+ Error_Msg_NE
+ ("descendant of mutably tagged type cannot be deeper than"
+ & " its root", N, Root_Type (T));
+
+ elsif Present (Incomplete_Or_Partial_View (T))
+ and then Is_Tagged_Type (Incomplete_Or_Partial_View (T))
+ then
+ Error_Msg_N
+ ("descendant of mutably tagged type cannot a have partial"
+ & " view which is tagged", N);
+
+ -- Mutably tagged types cannot have discriminants
+
+ elsif Present (Discriminant_Specifications (N)) then
+ Error_Msg_N
+ ("descendant of mutably tagged type cannot have"
+ & " discriminates", N);
+
+ elsif Present (Interfaces (T))
+ and then not Is_Empty_Elmt_List (Interfaces (T))
+ then
+ Error_Msg_N
+ ("descendant of mutably tagged type cannot implement"
+ & " an interface", N);
+
+ -- We have a valid descendant type
+
+ else
+ -- Set inherited attributes
+
+ Set_Has_Size_Clause (CW_Typ);
+ Set_RM_Size (CW_Typ, RM_Size (Root_Class_Typ));
+ Set_Is_Mutably_Tagged_Type (CW_Typ);
+
+ -- Generate a new class-wide equivalent type
+
+ Set_Class_Wide_Equivalent_Type (CW_Typ,
+ Make_CW_Equivalent_Type (CW_Typ, Empty, Actions));
+
+ Insert_List_After_And_Analyze (N, Actions);
+
+ -- Add a Compile_Time_Error sizing check as a hint
+ -- to the backend since we don't know the true size of
+ -- anything at this point.
+
+ Insert_After_And_Analyze (N,
+ Make_CW_Size_Compile_Check (T, Root_Class_Typ));
+ end if;
+ end if;
+ end;
+ end if;
+
-- AI-419: The parent type of an explicitly limited derived type must
-- be a limited type or a limited interface.
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index b59a56c139b..e75f8dfb6bc 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -36,6 +36,7 @@ with Exp_Util; use Exp_Util;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Namet.Sp; use Namet.Sp;
with Nlists; use Nlists;
@@ -623,6 +624,12 @@ package body Sem_Ch4 is
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constr)));
end;
+
+ -- Rewrite the mutably tagged type to a non-class-wide type for
+ -- proper initialization.
+
+ elsif Is_Mutably_Tagged_Type (Type_Id) then
+ Rewrite (E, New_Occurrence_Of (Etype (Type_Id), Loc));
end if;
end if;
@@ -2885,6 +2892,12 @@ package body Sem_Ch4 is
Set_Etype (N, Component_Type (Array_Type));
Check_Implicit_Dereference (N, Etype (N));
+ -- Generate conversion to class-wide type
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (N)) then
+ Make_Mutably_Tagged_Conversion (N);
+ end if;
+
if Present (Index) then
Error_Msg_N
("too few subscripts in array reference", First (Exprs));
@@ -4069,6 +4082,17 @@ package body Sem_Ch4 is
Next_Actual (Actual);
Next_Formal (Formal);
+ -- Generate a class-wide type conversion for instances of
+ -- class-wide equivalent types to their corresponding
+ -- mutably tagged type.
+
+ elsif Is_Mutably_Tagged_CW_Equivalent_Type (Etype (Actual))
+ and then Etype (Formal) = Parent_Subtype (Etype (Actual))
+ then
+ Make_Mutably_Tagged_Conversion (Actual);
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+
-- Handle failed type check
else
@@ -5294,6 +5318,11 @@ package body Sem_Ch4 is
Prefix_Type := Implicitly_Designated_Type (Prefix_Type);
end if;
+ -- Handle mutably tagged types
+
+ elsif Is_Class_Wide_Equivalent_Type (Prefix_Type) then
+ Prefix_Type := Parent_Subtype (Prefix_Type);
+
-- If we have an explicit dereference of a remote access-to-class-wide
-- value, then issue an error (see RM-E.2.2(16/1)). However we first
-- have to check for the case of a prefix that is a controlling operand
@@ -5389,7 +5418,6 @@ package body Sem_Ch4 is
Check_Implicit_Dereference (N, Etype (Comp));
elsif Is_Record_Type (Prefix_Type) then
-
-- Find a component with the given name. If the node is a prefixed
-- call, do not examine components whose visibility may be
-- accidental.
@@ -5559,6 +5587,13 @@ package body Sem_Ch4 is
Set_Etype (N, Etype (Comp));
end if;
+ -- 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);
+ end if;
+
Check_Implicit_Dereference (N, Etype (N));
return;
end if;
@@ -6328,6 +6363,30 @@ package body Sem_Ch4 is
("formal parameter cannot be converted to class-wide type when "
& "Extensions_Visible is False", Expr);
end if;
+
+ -- Perform special checking for access to mutably tagged type since they
+ -- are not compatible with interfaces.
+
+ if Is_Access_Type (Typ)
+ and then Is_Access_Type (Etype (Expr))
+ and then not Error_Posted (N)
+ then
+
+ if Is_Mutably_Tagged_Type (Directly_Designated_Type (Typ))
+ and then Is_Interface (Directly_Designated_Type (Etype (Expr)))
+ then
+ Error_Msg_N
+ ("argument of conversion to mutably tagged access type cannot "
+ & "be access to interface", Expr);
+
+ elsif Is_Mutably_Tagged_Type (Directly_Designated_Type (Etype (Expr)))
+ and then Is_Interface (Directly_Designated_Type (Typ))
+ then
+ Error_Msg_N
+ ("argument of conversion to interface access type cannot "
+ & "be access to mutably tagged type", Expr);
+ end if;
+ end if;
end Analyze_Type_Conversion;
----------------------
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 1e09e57919e..b92ceb17b1b 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -39,6 +39,7 @@ with Freeze; use Freeze;
with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -676,11 +677,17 @@ package body Sem_Ch5 is
Set_Assignment_Type (Lhs, T1);
- -- If the target of the assignment is an entity of a mutable type and
- -- the expression is a conditional expression, its alternatives can be
- -- of different subtypes of the nominal type of the LHS, so they must be
- -- resolved with the base type, given that their subtype may differ from
- -- that of the target mutable object.
+ -- When analyzing a mutably tagged class-wide equivalent type pretend we
+ -- are actually looking at the mutably tagged type itself for proper
+ -- analysis.
+
+ T1 := Get_Corresponding_Mutably_Tagged_Type_If_Present (T1);
+
+ -- If the target of the assignment is an entity of a mutably tagged type
+ -- and the expression is a conditional expression, its alternatives can
+ -- be of different subtypes of the nominal type of the LHS, so they must
+ -- be resolved with the base type, given that their subtype may differ
+ -- from that of the target mutable object.
if Is_Entity_Name (Lhs)
and then Is_Assignable (Entity (Lhs))
@@ -2500,6 +2507,13 @@ package body Sem_Ch5 is
Error_Msg_N
("iterable name cannot be a discriminant-dependent "
& "component of a mutable object", N);
+
+ elsif Depends_On_Mutably_Tagged_Ext_Comp
+ (Original_Node (Iter_Name))
+ then
+ Error_Msg_N
+ ("iterable name cannot depend on a mutably tagged component",
+ N);
end if;
Check_Subtype_Definition (Component_Type (Typ));
@@ -2630,6 +2644,13 @@ package body Sem_Ch5 is
Error_Msg_N
("container cannot be a discriminant-dependent "
& "component of a mutable object", N);
+
+ elsif Depends_On_Mutably_Tagged_Ext_Comp
+ (Orig_Iter_Name)
+ then
+ Error_Msg_N
+ ("container cannot depend on a mutably tagged "
+ & "component", N);
end if;
end if;
end;
@@ -2716,6 +2737,11 @@ package body Sem_Ch5 is
Error_Msg_N
("container cannot be a discriminant-dependent "
& "component of a mutable object", N);
+
+ elsif Depends_On_Mutably_Tagged_Ext_Comp (Obj) then
+ Error_Msg_N
+ ("container cannot depend on a mutably tagged"
+ & " component", N);
end if;
end;
end if;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 3252af79748..e97afdaf12e 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9182,9 +9182,15 @@ package body Sem_Ch6 is
-- If the type does not have a completion yet, treat as prior to
-- Ada 2012 for consistency.
- if Has_Discriminants (Formal_Type)
+ -- Note that we need also to handle mutably tagged types in the
+ -- same way as discriminated types since they can be constrained
+ -- or unconstrained as well.
+
+ if (Has_Discriminants (Formal_Type)
+ or else Is_Mutably_Tagged_Type (Formal_Type))
and then not Is_Constrained (Formal_Type)
- and then Is_Definite_Subtype (Formal_Type)
+ and then (Is_Definite_Subtype (Formal_Type)
+ or else Is_Mutably_Tagged_Type (Formal_Type))
and then (Ada_Version < Ada_2012
or else No (Underlying_Type (Formal_Type))
or else not
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 125ccc6c433..d2752af320e 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -39,6 +39,7 @@ with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref;
with Local_Restrict;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Namet.Sp; use Namet.Sp;
with Nlists; use Nlists;
@@ -1511,6 +1512,10 @@ package body Sem_Ch8 is
if Is_Dependent_Component_Of_Mutable_Object (Nam) then
Error_Msg_N
("illegal renaming of discriminant-dependent component", Nam);
+ elsif Depends_On_Mutably_Tagged_Ext_Comp (Nam) then
+ Error_Msg_N
+ ("illegal renaming of mutably tagged dependent component",
+ Nam);
end if;
-- If the renaming comes from source and the renamed object is a
@@ -2094,6 +2099,10 @@ package body Sem_Ch8 is
Error_Msg_N
("illegal renaming of discriminant-dependent component",
Nam);
+ elsif Depends_On_Mutably_Tagged_Ext_Comp (Nam) then
+ Error_Msg_N
+ ("illegal renaming of mutably tagged dependent component",
+ Nam);
end if;
else
Error_Msg_N ("expect object name in renaming", Nam);
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index d2eca7c5459..a0dd1f7962b 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -47,6 +47,7 @@ with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Local_Restrict;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
@@ -5034,12 +5035,21 @@ package body Sem_Res is
-- Skip this check on helpers and indirect-call wrappers built to
-- support class-wide preconditions.
+ -- We make special exception here for mutably tagged types and
+ -- related calls to their initialization procedures.
+
if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
and then not Is_Class_Wide_Type (F_Typ)
and then not Is_Controlling_Formal (F)
and then not In_Instance
and then (not Is_Subprogram (Nam)
or else No (Class_Preconditions_Subprogram (Nam)))
+
+ -- Ignore mutably tagged types and their use in calls to init
+ -- procs.
+
+ and then not Is_Mutably_Tagged_CW_Equivalent_Type (A_Typ)
+ and then not Is_Init_Proc (Nam)
then
Error_Msg_N ("class-wide argument not allowed here!", A);
@@ -14069,6 +14079,13 @@ package body Sem_Res is
end;
end if;
+ -- When we encounter a class-wide equivalent type used to represent
+ -- a fully sized mutably tagged type, pretend we are actually looking
+ -- at the class-wide mutably tagged type instead.
+
+ Opnd_Type :=
+ Get_Corresponding_Mutably_Tagged_Type_If_Present (Opnd_Type);
+
-- Deal with conversion of integer type to address if the pragma
-- Allow_Integer_Address is in effect. We convert the conversion to
-- an unchecked conversion in this case and we are all done.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 1705b5817b9..b1d47f22416 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -38,6 +38,7 @@ with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
+with Mutably_Tagged; use Mutably_Tagged;
with Namet.Sp; use Namet.Sp;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -17166,6 +17167,13 @@ package body Sem_Util is
-- Record types
elsif Is_Record_Type (Typ) then
+ -- Mutably tagged types get default initialized to their parent
+ -- subtype's default values.
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Typ) then
+ return True;
+ end if;
+
if Has_Defaulted_Discriminants (Typ)
and then Is_Fully_Initialized_Variant (Typ)
then
@@ -22684,6 +22692,11 @@ package body Sem_Util is
then
return True;
+ -- Mutably tagged types require default initialization
+
+ elsif Is_Mutably_Tagged_CW_Equivalent_Type (Typ) then
+ return True;
+
-- If Initialize/Normalize_Scalars is in effect, string objects also
-- need initialization, unless they are created in the course of
-- expanding an aggregate (since in the latter case they will be
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 08/16] ada: Minor tweak in Snames
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (5 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 07/16] ada: Add prototype for mutably tagged types Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 09/16] ada: Simplify handling of VxWorks-specific error codes for ENOENT Marc Poulhiès
` (7 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
gcc/ada/
* snames.ads-tmpl (Name_Present): Move to Repinfo section.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/snames.ads-tmpl | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 699b8df5851..d2f724f86ca 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -903,10 +903,6 @@ package Snames is
Name_Warn : constant Name_Id := N + $;
Name_Working_Storage : constant Name_Id := N + $;
- -- used by Repinfo JSON I/O
-
- Name_Present : constant Name_Id := N + $;
-
-- Names of recognized attributes. The entries with the comment "Ada 83"
-- are attributes that are defined in Ada 83, but not in Ada 95. These
-- attributes are implemented in all Ada modes in GNAT.
@@ -1372,6 +1368,7 @@ package Snames is
Name_Discriminant : constant Name_Id := N + $;
Name_Operands : constant Name_Id := N + $;
+ Name_Present : constant Name_Id := N + $;
-- Other miscellaneous names used in front end
-- Note that the UP_ prefix means use the rest of the name in uppercase,
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 09/16] ada: Simplify handling of VxWorks-specific error codes for ENOENT
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (6 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 08/16] ada: Minor tweak in Snames Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 10/16] ada: Bad tree built for Obj.Discrim_Dep_Component'Loop_Entry in assertion Marc Poulhiès
` (6 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Jerome Guitton
From: Jerome Guitton <guitton@adacore.com>
These error codes were defined on older versions of VxWorks (5, 6, 7
SR0540) and now they are either not defined or they fallback to
ENOENT. To handle these cases without using complex tests against
vxworks versions, leverage on __has_include and provide a fallback to
ENOENT if these error codes are not defined.
gcc/ada/
* sysdep.c (S_dosFsLib_FILE_NOT_FOUND, S_nfsLib_NFSERR_NOENT):
New macros, falback to ENOENT when not already defined.
(__gnat_is_file_not_found_error): Use these new macros to remove
tests against VxWorks flavors.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sysdep.c | 27 ++++++++++++++++++++-------
1 file changed, 20 insertions(+), 7 deletions(-)
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index 443b11f4302..254c736bec4 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -35,18 +35,35 @@
#ifdef __vxworks
#include "vxWorks.h"
#include "ioLib.h"
-#if ! defined (VTHREADS)
+/* VxWorks 5, 6 and 7 SR0540 expose error codes that need to be handled
+ as ENOENT. On later versions:
+ - either they are defined as ENOENT (vx7r2);
+ - or the corresponding system includes are not provided (Helix Cert). */
+
+#if __has_include ("dosFsLib.h")
+/* On helix-cert, this include is only provided for RTPs. */
#include "dosFsLib.h"
#endif
-#if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__))
+
+#ifndef S_dosFsLib_FILE_NOT_FOUND
+#define S_dosFsLib_FILE_NOT_FOUND ENOENT
+#endif
+
+#if __has_include ("nfsLib.h")
+/* This include is not provided for RTPs or on helix-cert. */
# include "nfsLib.h"
#endif
+
+#ifndef S_nfsLib_NFSERR_NOENT
+#define S_nfsLib_NFSERR_NOENT ENOENT
+#endif
+
#include "selectLib.h"
#include "version.h"
#if defined (__RTP__)
# include "vwModNum.h"
#endif /* __RTP__ */
-#endif
+#endif /* __vxworks */
#ifdef __ANDROID__
#undef __linux__
@@ -912,14 +929,10 @@ __gnat_is_file_not_found_error (int errno_val)
/* In the case of VxWorks, we also have to take into account various
* filesystem-specific variants of this error.
*/
-#if ! defined (VTHREADS) && (_WRS_VXWORKS_MAJOR < 7)
else if (errno_val == S_dosFsLib_FILE_NOT_FOUND)
return 1;
-#endif
-#if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__))
else if (errno_val == S_nfsLib_NFSERR_NOENT)
return 1;
-#endif
#if defined (__RTP__)
/* An RTP can return an NFS file not found, and the NFS bits must
first be masked on to check the errno. */
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 10/16] ada: Bad tree built for Obj.Discrim_Dep_Component'Loop_Entry in assertion
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (7 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 09/16] ada: Simplify handling of VxWorks-specific error codes for ENOENT Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 11/16] ada: Fix parts of classification of aspects Marc Poulhiès
` (5 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Steve Baird
From: Steve Baird <baird@adacore.com>
The Etype for an N_Selected_Component node usually should not match the Etype
of the referenced component if the component is subject to a
discriminant-dependent constraint. Instead Build_Actual_Subtype_Of_Component
should be called. Fix a case where this rule was not being followed (because
B_A_S_O_C is not called during preanalysis of a component selection), resulting
in a tree that confused CodePeer because the subtype was wrong.
gcc/ada/
* exp_attr.adb
(Expand_Loop_Entry_Attribute):
Ensure that Etype of the saved expression is set correctly.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_attr.adb | 25 ++++++++++++++++++-------
1 file changed, 18 insertions(+), 7 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 1396007a2d1..5c85b4912d2 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -1780,14 +1780,25 @@ package body Exp_Attr is
begin
Aux_Decl := Empty;
- -- Generate a nominal type for the constant when the prefix is of
- -- a constrained type. This is achieved by setting the Etype of
- -- the relocated prefix to its base type. Since the prefix is now
- -- the initialization expression of the constant, its freezing
- -- will produce a proper nominal type.
-
Temp_Expr := Relocate_Node (Pref);
- Set_Etype (Temp_Expr, Base_Typ);
+
+ -- For Etype (Temp_Expr) in some cases we cannot use either
+ -- Etype (Pref) or Base_Typ. So we set Etype (Temp_Expr) to null
+ -- and mark Temp_Expr as requiring analysis. Rather than trying
+ -- to sort out exactly when this is needed, we do it
+ -- unconditionally.
+ -- One case where this is needed is when
+ -- 1) Pref is an N_Selected_Component name that
+ -- refers to a component which is subject to a
+ -- discriminant-dependent constraint; and
+ -- 2) The prefix of that N_Selected_Component refers to a
+ -- formal parameter with an unconstrained subtype; and
+ -- 3) Pref has only been preanalyzed (so that
+ -- Build_Actual_Subtype_Of_Component has not been called
+ -- and Etype (Pref) equals the Etype of the component).
+
+ Set_Etype (Temp_Expr, Empty);
+ Set_Analyzed (Temp_Expr, False);
-- Generate:
-- Temp : constant Base_Typ := Pref;
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 11/16] ada: Fix parts of classification of aspects
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (8 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 10/16] ada: Bad tree built for Obj.Discrim_Dep_Component'Loop_Entry in assertion Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 12/16] ada: Typo and indentation fix Marc Poulhiès
` (4 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
Many aspects are (correctly) marked as GNAT-specific but nevertheless not
listed in the Implementation_Defined_Aspect array, so this aligns the two
sides and also removes Default_Initial_Condition and Object_Size from the
list, since they are defined in Ada 2022.
This also moves No_Controlled_Parts and No_Task_Parts to the subclass of
boolean aspects, and completes the list of nonoverridable aspects defined
in Ada 2022.
gcc/ada/
* aspects.ads (Aspect_Id): Alphabetize, remove the GNAT tag from
Default_Initial_Condition and Object_Size, move No_Controlled_Parts
and No_Task_Parts to boolean subclass.
(Nonoverridable_Aspect_Id): Add missing Ada 2022 aspects.
(Implementation_Defined_Aspect): Add all missing aspects, remove
Max_Entry_Queue_Length and Object_Size
(Aspect_Argument): Remove specific entries for No_Controlled_Parts
and No_Task_Parts, list boolean aspects last.
(Is_Representation_Aspect ): Move boolean aspects last.
(Aspect_Names): Alphabetize.
* sem_ch13.adb (Analyze_Aspect_Disable_Controlled): Adjust.
(Analyze_Aspect_Specifications): Move around processing for
No_Controlled_Parts and No_Task_Parts.
(Check_Aspect_At_Freeze_Point): Remove specific entries for
No_Controlled_Parts and No_Task_Parts
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 94 ++++++++++++++++++++++++++++----------------
gcc/ada/sem_ch13.adb | 69 +++++++++++++++++++-------------
2 files changed, 101 insertions(+), 62 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index d4aafb1a4f1..202d42193d1 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -64,10 +64,14 @@ with Types; use Types;
package Aspects is
- -- Type defining recognized aspects
+ -- Type enumerating the recognized aspects. The GNAT tag must be in keeping
+ -- with the Implementation_Defined_Aspect array below.
type Aspect_Id is
(No_Aspect, -- Dummy entry for no aspect
+
+ -- The following aspects do not have a (static) boolean value
+
Aspect_Abstract_State, -- GNAT
Aspect_Address,
Aspect_Aggregate,
@@ -81,7 +85,7 @@ package Aspects is
Aspect_Convention,
Aspect_CPU,
Aspect_Default_Component_Value,
- Aspect_Default_Initial_Condition, -- GNAT
+ Aspect_Default_Initial_Condition,
Aspect_Default_Iterator,
Aspect_Default_Storage_Pool,
Aspect_Default_Value,
@@ -104,8 +108,8 @@ package Aspects is
Aspect_Integer_Literal,
Aspect_Interrupt_Priority,
Aspect_Invariant, -- GNAT
- Aspect_Iterator_Element,
Aspect_Iterable, -- GNAT
+ Aspect_Iterator_Element,
Aspect_Link_Name,
Aspect_Linker_Section, -- GNAT
Aspect_Local_Restrictions, -- GNAT
@@ -113,9 +117,7 @@ package Aspects is
Aspect_Max_Entry_Queue_Depth, -- GNAT
Aspect_Max_Entry_Queue_Length,
Aspect_Max_Queue_Length, -- GNAT
- Aspect_No_Controlled_Parts,
- Aspect_No_Task_Parts, -- GNAT
- Aspect_Object_Size, -- GNAT
+ Aspect_Object_Size,
Aspect_Obsolescent, -- GNAT
Aspect_Output,
Aspect_Part_Of, -- GNAT
@@ -186,10 +188,10 @@ package Aspects is
Aspect_Atomic,
Aspect_Atomic_Components,
Aspect_Constant_After_Elaboration, -- GNAT
- Aspect_Disable_Controlled, -- GNAT
- Aspect_Discard_Names,
Aspect_CUDA_Device, -- GNAT
Aspect_CUDA_Global, -- GNAT
+ Aspect_Disable_Controlled, -- GNAT
+ Aspect_Discard_Names,
Aspect_Effective_Reads, -- GNAT
Aspect_Effective_Writes, -- GNAT
Aspect_Exclusive_Functions,
@@ -206,9 +208,11 @@ package Aspects is
Aspect_Interrupt_Handler,
Aspect_Lock_Free, -- GNAT
Aspect_No_Caching, -- GNAT
+ Aspect_No_Controlled_Parts,
Aspect_No_Inline, -- GNAT
Aspect_No_Return,
Aspect_No_Tagged_Streams, -- GNAT
+ Aspect_No_Task_Parts, -- GNAT
Aspect_Pack,
Aspect_Persistent_BSS, -- GNAT
Aspect_Preelaborable_Initialization,
@@ -242,12 +246,13 @@ package Aspects is
| Aspect_Constant_Indexing
| Aspect_Default_Iterator
| Aspect_Implicit_Dereference
+ | Aspect_Integer_Literal
| Aspect_Iterator_Element
| Aspect_Max_Entry_Queue_Length
| Aspect_No_Controlled_Parts
+ | Aspect_Real_Literal
+ | Aspect_String_Literal
| Aspect_Variable_Indexing;
- -- ??? No_Controlled_Parts not yet in Aspect_Id enumeration see RM
- -- 13.1.1(18.7).
-- The following array indicates aspects that accept 'Class
@@ -275,9 +280,13 @@ package Aspects is
Aspect_Async_Writers => True,
Aspect_Constant_After_Elaboration => True,
Aspect_Contract_Cases => True,
+ Aspect_CUDA_Device => True,
+ Aspect_CUDA_Global => True,
Aspect_Depends => True,
+ Aspect_Designated_Storage_Model => True,
Aspect_Dimension => True,
Aspect_Dimension_System => True,
+ Aspect_Disable_Controlled => True,
Aspect_Effective_Reads => True,
Aspect_Effective_Writes => True,
Aspect_Exceptional_Cases => True,
@@ -287,16 +296,30 @@ package Aspects is
Aspect_Ghost_Predicate => True,
Aspect_Global => True,
Aspect_GNAT_Annotate => True,
+ Aspect_Initial_Condition => True,
+ Aspect_Initializes => True,
Aspect_Inline_Always => True,
Aspect_Invariant => True,
+ Aspect_Iterable => True,
+ Aspect_Linker_Section => True,
+ Aspect_Local_Restrictions => True,
Aspect_Lock_Free => True,
Aspect_Max_Entry_Queue_Depth => True,
- Aspect_Max_Entry_Queue_Length => True,
Aspect_Max_Queue_Length => True,
- Aspect_Object_Size => True,
+ Aspect_No_Caching => True,
+ Aspect_No_Elaboration_Code_All => True,
+ Aspect_No_Inline => True,
+ Aspect_No_Tagged_Streams => True,
+ Aspect_No_Task_Parts => True,
+ Aspect_Obsolescent => True,
+ Aspect_Part_Of => True,
Aspect_Persistent_BSS => True,
Aspect_Predicate => True,
Aspect_Pure_Function => True,
+ Aspect_Refined_Depends => True,
+ Aspect_Refined_Global => True,
+ Aspect_Refined_Post => True,
+ Aspect_Refined_State => True,
Aspect_Relaxed_Initialization => True,
Aspect_Remote_Access_Type => True,
Aspect_Scalar_Storage_Order => True,
@@ -305,16 +328,21 @@ package Aspects is
Aspect_Side_Effects => True,
Aspect_Simple_Storage_Pool => True,
Aspect_Simple_Storage_Pool_Type => True,
+ Aspect_SPARK_Mode => True,
+ Aspect_Storage_Model_Type => True,
Aspect_Subprogram_Variant => True,
Aspect_Suppress_Debug_Info => True,
Aspect_Suppress_Initialization => True,
Aspect_Thread_Local_Storage => True,
Aspect_Test_Case => True,
+ Aspect_Unimplemented => True,
Aspect_Universal_Aliasing => True,
Aspect_Unmodified => True,
Aspect_Unreferenced => True,
Aspect_Unreferenced_Objects => True,
+ Aspect_User_Aspect => True,
Aspect_Value_Size => True,
+ Aspect_Volatile_Full_Access => True,
Aspect_Volatile_Function => True,
Aspect_Warnings => True,
others => False);
@@ -329,8 +357,8 @@ package Aspects is
(Aspect_Aggregate => True,
Aspect_Constant_Indexing => True,
Aspect_Default_Iterator => True,
- Aspect_Iterator_Element => True,
Aspect_Iterable => True,
+ Aspect_Iterator_Element => True,
Aspect_Variable_Indexing => True,
others => False);
@@ -425,8 +453,6 @@ package Aspects is
Aspect_Max_Entry_Queue_Depth => Expression,
Aspect_Max_Entry_Queue_Length => Expression,
Aspect_Max_Queue_Length => Expression,
- Aspect_No_Controlled_Parts => Optional_Expression,
- Aspect_No_Task_Parts => Optional_Expression,
Aspect_Object_Size => Expression,
Aspect_Obsolescent => Optional_Expression,
Aspect_Output => Name,
@@ -473,8 +499,8 @@ package Aspects is
Aspect_Warnings => Name,
Aspect_Write => Name,
- Boolean_Aspects => Optional_Expression,
- Library_Unit_Aspects => Optional_Expression);
+ Library_Unit_Aspects => Optional_Expression,
+ Boolean_Aspects => Optional_Expression);
-- The following array indicates what aspects are representation aspects
@@ -484,20 +510,14 @@ package Aspects is
Aspect_Address => True,
Aspect_Aggregate => False,
Aspect_Alignment => True,
- Aspect_Always_Terminates => False,
Aspect_Annotate => False,
- Aspect_Async_Readers => False,
- Aspect_Async_Writers => False,
Aspect_Attach_Handler => False,
Aspect_Bit_Order => True,
Aspect_Component_Size => True,
- Aspect_Constant_After_Elaboration => False,
Aspect_Constant_Indexing => False,
Aspect_Contract_Cases => False,
Aspect_Convention => True,
Aspect_CPU => False,
- Aspect_CUDA_Device => False,
- Aspect_CUDA_Global => False,
Aspect_Default_Component_Value => True,
Aspect_Default_Initial_Condition => False,
Aspect_Default_Iterator => False,
@@ -509,14 +529,10 @@ package Aspects is
Aspect_Dimension_System => False,
Aspect_Dispatching_Domain => False,
Aspect_Dynamic_Predicate => False,
- Aspect_Effective_Reads => False,
- Aspect_Effective_Writes => False,
Aspect_Exceptional_Cases => False,
Aspect_Exclusive_Functions => False,
- Aspect_Extensions_Visible => False,
Aspect_External_Name => False,
Aspect_External_Tag => False,
- Aspect_Ghost => False,
Aspect_Ghost_Predicate => False,
Aspect_Global => False,
Aspect_GNAT_Annotate => False,
@@ -536,9 +552,6 @@ package Aspects is
Aspect_Max_Entry_Queue_Depth => False,
Aspect_Max_Entry_Queue_Length => False,
Aspect_Max_Queue_Length => False,
- Aspect_No_Caching => False,
- Aspect_No_Controlled_Parts => False,
- Aspect_No_Task_Parts => False,
Aspect_Object_Size => True,
Aspect_Obsolescent => False,
Aspect_Output => False,
@@ -561,7 +574,6 @@ package Aspects is
Aspect_Relaxed_Initialization => False,
Aspect_Scalar_Storage_Order => True,
Aspect_Secondary_Stack_Size => True,
- Aspect_Side_Effects => False,
Aspect_Simple_Storage_Pool => True,
Aspect_Size => True,
Aspect_Small => True,
@@ -583,36 +595,49 @@ package Aspects is
Aspect_User_Aspect => False,
Aspect_Value_Size => True,
Aspect_Variable_Indexing => False,
- Aspect_Volatile_Function => False,
Aspect_Warnings => False,
Aspect_Write => False,
Library_Unit_Aspects => False,
+ Aspect_Always_Terminates => False,
Aspect_Asynchronous => True,
+ Aspect_Async_Readers => False,
+ Aspect_Async_Writers => False,
Aspect_Atomic => True,
Aspect_Atomic_Components => True,
+ Aspect_Constant_After_Elaboration => False,
+ Aspect_CUDA_Device => False,
+ Aspect_CUDA_Global => False,
Aspect_Disable_Controlled => False,
Aspect_Discard_Names => True,
+ Aspect_Effective_Reads => False,
+ Aspect_Effective_Writes => False,
Aspect_Export => True,
+ Aspect_Extensions_Visible => False,
Aspect_Favor_Top_Level => False,
Aspect_Full_Access_Only => True,
+ Aspect_Ghost => False,
+ Aspect_Import => True,
Aspect_Independent => True,
Aspect_Independent_Components => True,
- Aspect_Import => True,
Aspect_Inline => False,
Aspect_Inline_Always => False,
Aspect_Interrupt_Handler => False,
Aspect_Lock_Free => False,
+ Aspect_No_Caching => False,
+ Aspect_No_Controlled_Parts => False,
Aspect_No_Inline => False,
Aspect_No_Return => False,
Aspect_No_Tagged_Streams => False,
+ Aspect_No_Task_Parts => False,
Aspect_Pack => True,
Aspect_Persistent_BSS => True,
Aspect_Preelaborable_Initialization => False,
Aspect_Pure_Function => False,
Aspect_Remote_Access_Type => False,
Aspect_Shared => True,
+ Aspect_Side_Effects => False,
Aspect_Simple_Storage_Pool_Type => True,
Aspect_Static => False,
Aspect_Suppress_Debug_Info => False,
@@ -626,6 +651,7 @@ package Aspects is
Aspect_Volatile => True,
Aspect_Volatile_Components => True,
Aspect_Volatile_Full_Access => True,
+ Aspect_Volatile_Function => False,
Aspect_Yield => False);
-----------------------------------------
@@ -699,8 +725,8 @@ package Aspects is
Aspect_Interrupt_Handler => Name_Interrupt_Handler,
Aspect_Interrupt_Priority => Name_Interrupt_Priority,
Aspect_Invariant => Name_Invariant,
- Aspect_Iterator_Element => Name_Iterator_Element,
Aspect_Iterable => Name_Iterable,
+ Aspect_Iterator_Element => Name_Iterator_Element,
Aspect_Link_Name => Name_Link_Name,
Aspect_Linker_Section => Name_Linker_Section,
Aspect_Lock_Free => Name_Lock_Free,
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 2fbddf3f952..cd47f734462 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1869,6 +1869,8 @@ package body Sem_Ch13 is
procedure Analyze_Aspect_Disable_Controlled is
begin
+ Error_Msg_Name_1 := Nam;
+
-- The aspect applies only to controlled records
if not (Ekind (E) = E_Record_Type
@@ -3796,32 +3798,6 @@ package body Sem_Ch13 is
Insert_Pragma (Aitem);
goto Continue;
- -- No_Controlled_Parts, No_Task_Parts
-
- when Aspect_No_Controlled_Parts | Aspect_No_Task_Parts =>
-
- -- Check appropriate type argument
-
- if not Is_Type (E) then
- Error_Msg_N
- ("aspect % can only be applied to types", E);
- end if;
-
- -- Disallow subtypes
-
- if Nkind (Declaration_Node (E)) = N_Subtype_Declaration then
- Error_Msg_N
- ("aspect % cannot be applied to subtypes", E);
- end if;
-
- -- Resolve the expression to a boolean
-
- if Present (Expr) then
- Check_Expr_Is_OK_Static_Expression (Expr, Any_Boolean);
- end if;
-
- goto Continue;
-
-- Obsolescent
when Aspect_Obsolescent => declare
@@ -4503,6 +4479,45 @@ package body Sem_Ch13 is
elsif A_Id = Aspect_Full_Access_Only then
Error_Msg_Ada_2022_Feature ("aspect %", Loc);
+ -- No_Controlled_Parts, No_Task_Parts
+
+ elsif A_Id in Aspect_No_Controlled_Parts
+ | Aspect_No_Task_Parts
+ then
+ Error_Msg_Name_1 := Nam;
+
+ -- Disallow formal types
+
+ if Nkind (Original_Node (N)) = N_Formal_Type_Declaration
+ then
+ Error_Msg_N
+ ("aspect % not allowed for formal type declaration",
+ Aspect);
+
+ -- Disallow subtypes
+
+ elsif Nkind (Original_Node (N)) = N_Subtype_Declaration
+ then
+ Error_Msg_N
+ ("aspect % not allowed for subtype declaration",
+ Aspect);
+
+ -- Accept all other types
+
+ elsif not Is_Type (E) then
+ Error_Msg_N
+ ("aspect % can only be specified for a type",
+ Aspect);
+ end if;
+
+ -- Resolve the expression to a boolean
+
+ if Present (Expr) then
+ Check_Expr_Is_OK_Static_Expression (Expr, Any_Boolean);
+ end if;
+
+ goto Continue;
+
-- Ada 2022 (AI12-0075): static expression functions
elsif A_Id = Aspect_Static then
@@ -11539,8 +11554,6 @@ package body Sem_Ch13 is
| Aspect_Max_Entry_Queue_Depth
| Aspect_Max_Entry_Queue_Length
| Aspect_Max_Queue_Length
- | Aspect_No_Controlled_Parts
- | Aspect_No_Task_Parts
| Aspect_Obsolescent
| Aspect_Part_Of
| Aspect_Post
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 12/16] ada: Typo and indentation fix
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (9 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 11/16] ada: Fix parts of classification of aspects Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 13/16] ada: Do not create null GCC thunks Marc Poulhiès
` (3 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Marc Poulhiès
Fixes typo in comments and 2 instances of bad indentation.
gcc/ada/
* gcc-interface/decl.cc (gnat_to_gnu_entity): Typo fix.
(gnat_to_gnu_component_type): Indent fix.
* gcc-interface/gigi.h (build_call_alloc_dealloc): Typo fix.
* gcc-interface/utils.cc (make_dummy_type): Typo fix.
* gcc-interface/utils2.cc (gnat_protect_expr): Indent fix.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/decl.cc | 8 ++++----
gcc/ada/gcc-interface/gigi.h | 2 +-
gcc/ada/gcc-interface/utils.cc | 2 +-
gcc/ada/gcc-interface/utils2.cc | 2 +-
4 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 8b72c96c439..23983742605 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -1384,7 +1384,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
volatile_flag = false;
gnu_size = NULL_TREE;
- /* In case this was a aliased object whose nominal subtype is
+ /* In case this was an aliased object whose nominal subtype is
unconstrained, the pointer above will be a thin pointer and
build_allocator will automatically make the template.
@@ -2103,7 +2103,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
1. the array type (suffix XUA) containing the actual data,
- 2. the template type (suffix XUB) containng the bounds,
+ 2. the template type (suffix XUB) containing the bounds,
3. the fat pointer type (suffix XUP) representing a pointer or a
reference to the unconstrained array type:
@@ -5445,8 +5445,8 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
if (gnu_comp_align > TYPE_ALIGN (gnu_type))
gnu_comp_align = 0;
}
- else
- gnu_comp_align = 0;
+ else
+ gnu_comp_align = 0;
gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, gnu_comp_align,
gnat_array, true, definition, true);
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index f3205a8a25d..6ed74d6879e 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -906,7 +906,7 @@ extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size,
Entity_Id gnat_pool, Node_Id gnat_node);
/* Build a GCC tree to correspond to allocating an object of TYPE whose
- initial value if INIT, if INIT is nonzero. Convert the expression to
+ initial value is INIT, if INIT is nonzero. Convert the expression to
RESULT_TYPE, which must be some type of pointer. Return the tree.
GNAT_PROC and GNAT_POOL optionally give the procedure to call and
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index ae520542ace..771cb1a17ca 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -499,7 +499,7 @@ make_dummy_type (Entity_Id gnat_type)
if (No (gnat_equiv))
gnat_equiv = gnat_type;
- /* If it there already a dummy type, use that one. Else make one. */
+ /* If there is already a dummy type, use that one. Else make one. */
if (PRESENT_DUMMY_NODE (gnat_equiv))
return GET_DUMMY_NODE (gnat_equiv);
diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
index 4b7e2739f6a..70271cf2836 100644
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -2884,7 +2884,7 @@ gnat_protect_expr (tree exp)
if (code == NON_LVALUE_EXPR
|| CONVERT_EXPR_CODE_P (code)
|| code == VIEW_CONVERT_EXPR)
- return build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
+ return build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
/* If we're indirectly referencing something, we only need to protect the
address since the data itself can't change in these situations. */
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 13/16] ada: Do not create null GCC thunks
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (10 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 12/16] ada: Typo and indentation fix Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 14/16] ada: Skip subprogram body entities inside scopes Marc Poulhiès
` (2 subsequent siblings)
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This prevents Gigi from creating null GCC thunks, i.e. thunks that have all
their internal parameters set to zero, replacing them with aliases. They
can arise in degenerate cases and null thunks would trip on an assertion in
former_thunk_p when they are later optimized.
gcc/ada/
PR ada/109817
* gcc-interface/trans.cc (maybe_make_gnu_thunk): Create an alias
instead of a null thunk.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 29 +++++++++++++++++++----------
1 file changed, 19 insertions(+), 10 deletions(-)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 93978c0f0ba..5256095dfeb 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -11093,6 +11093,16 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
tree gnu_interface_offset
= gnu_interface_tag ? byte_position (gnu_interface_tag) : NULL_TREE;
+ /* But we generate a call to the Thunk_Entity in the thunk. */
+ tree gnu_target
+ = gnat_to_gnu_entity (Thunk_Entity (gnat_thunk), NULL_TREE, false);
+
+ /* If the target is local, then thunk and target must have the same context
+ because cgraph_node::expand_thunk can only forward the static chain. */
+ if (DECL_STATIC_CHAIN (gnu_target)
+ && DECL_CONTEXT (gnu_thunk) != DECL_CONTEXT (gnu_target))
+ return false;
+
/* There are three ways to retrieve the offset between the interface view
and the base object. Either the controlling type covers the interface
type and the offset of the corresponding tag is fixed, in which case it
@@ -11111,6 +11121,15 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
virtual_value = 0;
virtual_offset = NULL_TREE;
indirect_offset = 0;
+
+ /* Do not create a null thunk, instead make it an alias. */
+ if (fixed_offset == 0)
+ {
+ SET_DECL_ASSEMBLER_NAME (gnu_thunk, DECL_ASSEMBLER_NAME (gnu_target));
+ (void) cgraph_node::get_create (gnu_target);
+ (void) cgraph_node::create_alias (gnu_thunk, gnu_target);
+ return true;
+ }
}
else if (!gnu_interface_offset
&& !Is_Variable_Size_Record (gnat_controlling_type))
@@ -11132,16 +11151,6 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
indirect_offset = (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
}
- /* But we generate a call to the Thunk_Entity in the thunk. */
- tree gnu_target
- = gnat_to_gnu_entity (Thunk_Entity (gnat_thunk), NULL_TREE, false);
-
- /* If the target is local, then thunk and target must have the same context
- because cgraph_node::expand_thunk can only forward the static chain. */
- if (DECL_STATIC_CHAIN (gnu_target)
- && DECL_CONTEXT (gnu_thunk) != DECL_CONTEXT (gnu_target))
- return false;
-
/* If the target returns by invisible reference and is external, apply the
same transformation as Subprogram_Body_to_gnu here. */
if (TREE_ADDRESSABLE (TREE_TYPE (gnu_target))
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 14/16] ada: Skip subprogram body entities inside scopes
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (11 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 13/16] ada: Do not create null GCC thunks Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 15/16] ada: Fix return mechanism reported by -gnatRm Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 16/16] ada: Do not include target-specific makefile fragments Marc Poulhiès
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Yannick Moy
From: Yannick Moy <moy@adacore.com>
Entities of kind E_Subprogram_Body, used on bodies of subprograms for
which there is a separate declaration, have been added in the entities
linked from a scope in order to get the representation information on
their enclosed object and type declarations. Skip these entities in gigi.
gcc/ada/
* gcc-interface/trans.cc (elaborate_all_entities_for_package)
(process_freeze_entity): Skip entities of kind E_Subprogram_Body.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 5256095dfeb..e68fb3fd776 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -9321,6 +9321,10 @@ elaborate_all_entities_for_package (Entity_Id gnat_package)
if (kind == E_Package_Body)
continue;
+ /* Skip subprogram bodies. */
+ if (kind == E_Subprogram_Body)
+ continue;
+
/* Skip limited views that point back to the main unit. */
if (IN (kind, Incomplete_Kind)
&& From_Limited_With (gnat_entity)
@@ -9427,6 +9431,10 @@ process_freeze_entity (Node_Id gnat_node)
if (Is_Subprogram (gnat_entity) && Present (Interface_Alias (gnat_entity)))
return;
+ /* Skip subprogram bodies. */
+ if (kind == E_Subprogram_Body)
+ return;
+
/* Check for an old definition if this isn't an object with address clause,
since the saved GCC tree is the address expression in that case. */
gnu_old
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 15/16] ada: Fix return mechanism reported by -gnatRm
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (12 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 14/16] ada: Skip subprogram body entities inside scopes Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 16/16] ada: Do not include target-specific makefile fragments Marc Poulhiès
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The return mechanism of functions is reported when the -gnatRm switch is
specified, but it is incorrect when the result type is not a by-reference
type in the language sense but is nevertheless returned by reference.
gcc/ada/
* gcc-interface/decl.cc: Include function.h.
(gnat_to_gnu_param): Minor comment tweaks.
(gnat_to_gnu_subprog_type): Take into account the default for the
computation of the return mechanism. Give a warning if a by-copy
specified mechanism cannot be honored.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/decl.cc | 34 +++++++++++++++++++++++++++-------
1 file changed, 27 insertions(+), 7 deletions(-)
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 23983742605..aa31a888818 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -27,6 +27,7 @@
#include "system.h"
#include "coretypes.h"
#include "target.h"
+#include "function.h"
#include "tree.h"
#include "gimple-expr.h"
#include "stringpool.h"
@@ -5703,6 +5704,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
input_location = saved_location;
+ /* Warn if we are asked to pass by copy but cannot. */
if (mech == By_Copy && (by_ref || by_component_ptr))
post_error ("??cannot pass & by copy", gnat_param);
@@ -5735,12 +5737,13 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p;
Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_param));
- /* If no Mechanism was specified, indicate what we're using, then
- back-annotate it. */
+ /* If no Mechanism was specified, indicate what we will use. */
if (mech == Default)
mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
+ /* Back-annotate the mechanism in all cases. */
Set_Mechanism (gnat_param, mech);
+
return gnu_param;
}
@@ -6129,11 +6132,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
associate_subprog_with_dummy_type (gnat_subprog, gnu_return_type);
incomplete_profile_p = true;
}
-
- if (kind == E_Function)
- Set_Mechanism (gnat_subprog, return_by_direct_ref_p
- || return_by_invisi_ref_p
- ? By_Reference : By_Copy);
}
/* A procedure (something that doesn't return anything) shouldn't be
@@ -6636,6 +6634,28 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
if (warn_shadow)
post_error ("'G'C'C builtin not found for&!??", gnat_subprog);
}
+
+ /* Finally deal with the return mechanism for a function. */
+ if (kind == E_Function)
+ {
+ /* We return by reference either if this is required by the semantics
+ of the language or if this is the default for the function. */
+ const bool by_ref = return_by_direct_ref_p
+ || return_by_invisi_ref_p
+ || aggregate_value_p (gnu_return_type, gnu_type);
+ Mechanism_Type mech = Mechanism (gnat_subprog);
+
+ /* Warn if we are asked to return by copy but cannot. */
+ if (mech == By_Copy && by_ref)
+ post_error ("??cannot return from & by copy", gnat_subprog);
+
+ /* If no mechanism was specified, indicate what we will use. */
+ if (mech == Default)
+ mech = by_ref ? By_Reference : By_Copy;
+
+ /* Back-annotate the mechanism in all cases. */
+ Set_Mechanism (gnat_subprog, mech);
+ }
}
*param_list = gnu_param_list;
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
* [COMMITTED 16/16] ada: Do not include target-specific makefile fragments
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
` (13 preceding siblings ...)
2024-06-14 7:36 ` [COMMITTED 15/16] ada: Fix return mechanism reported by -gnatRm Marc Poulhiès
@ 2024-06-14 7:36 ` Marc Poulhiès
14 siblings, 0 replies; 16+ messages in thread
From: Marc Poulhiès @ 2024-06-14 7:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
They are unused in this context.
gcc/ada/
* gcc-interface/Makefile.in (tmake_file): Remove all references.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/Makefile.in | 6 ------
1 file changed, 6 deletions(-)
diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in
index 0666fc00bb8..29db89c6f52 100644
--- a/gcc/ada/gcc-interface/Makefile.in
+++ b/gcc/ada/gcc-interface/Makefile.in
@@ -148,7 +148,6 @@ host_vendor=@host_vendor@
host_os=@host_os@
target_cpu_default = @target_cpu_default@
xmake_file = @xmake_file@
-tmake_file = @tmake_file@
#version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c`
#mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c`
@@ -209,11 +208,6 @@ all: all.indirect
# This tells GNU Make version 3 not to put all variables in the environment.
.NOEXPORT:
-# target overrides
-ifneq ($(tmake_file),)
-include $(tmake_file)
-endif
-
# host overrides
ifneq ($(xmake_file),)
include $(xmake_file)
--
2.45.1
^ permalink raw reply [flat|nested] 16+ messages in thread
end of thread, other threads:[~2024-06-14 7:36 UTC | newest]
Thread overview: 16+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-06-14 7:36 [COMMITTED 01/16] ada: Remove unused name of aspect from Snames Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 02/16] ada: Allow implicit dereferenced for uses of 'Super Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 03/16] ada: Couple of small cleanups in semantic analysis of aspects Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 04/16] ada: Missing initialization of multidimensional array using sliding Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 05/16] ada: Minor tweaks to processing of Aggregate aspect Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 06/16] ada: Crash checking accessibility level on private type Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 07/16] ada: Add prototype for mutably tagged types Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 08/16] ada: Minor tweak in Snames Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 09/16] ada: Simplify handling of VxWorks-specific error codes for ENOENT Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 10/16] ada: Bad tree built for Obj.Discrim_Dep_Component'Loop_Entry in assertion Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 11/16] ada: Fix parts of classification of aspects Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 12/16] ada: Typo and indentation fix Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 13/16] ada: Do not create null GCC thunks Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 14/16] ada: Skip subprogram body entities inside scopes Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 15/16] ada: Fix return mechanism reported by -gnatRm Marc Poulhiès
2024-06-14 7:36 ` [COMMITTED 16/16] ada: Do not include target-specific makefile fragments Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).