* [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 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