From: Ronan Desplanques <[email protected]>
This patch replaces aspect-based version of the destructors extension
with a new version that uses the "direct attribute definition" syntax
that was recently introduced by the constructors extension.
gcc/ada/ChangeLog:
* snames.ads-tmpl: Make "Destructor" an attribute name.
* snames.adb-tmpl: Allow direct attribute definition for Destructor.
* gen_il-fields.ads (Destructor): New field.
(Is_Destructor): Remove.
* gen_il-gen-gen_entities.adb: (Destructor): New field.
(Is_Destructor): Remove.
* einfo.ads (Destructor): Document new field.
(Is_Destructor): Remove documentation.
* aspects.ads (Aspect_Destructor): Remove.
* exp_attr.adb (Expand_N_Attribute_Reference): Adapt after aspect
removal.
* exp_ch7.adb (Build_Finalize_Statements): Adapt to new destructor
representation.
* freeze.adb (Freeze_Entity): Remove obsolete check.
* sem_attr.adb (Analyze_Attribute, Eval_Attribute): Adapt to new
attribute.
* sem_ch13.adb (Analyze_Aspect_Specifications,
Check_Aspect_At_End_Of_Declarations): Adapt after aspect removal.
* sem_ch6.adb (Analyze_Direct_Attribute_Definition): Add handling
of Destructor attribute.
(Can_Be_Destructor_Of): New function.
* doc/gnat_rm/gnat_language_extensions.rst: Adapt documentation to
new syntax.
* gnat_rm.texi: Regenerate.
* gnat_ugn.texi: Regenerate.
Tested on x86_64-pc-linux-gnu (before the recent bootstrap breakage), committed
on master.
---
gcc/ada/aspects.ads | 6 --
.../doc/gnat_rm/gnat_language_extensions.rst | 77 ++++++++----------
gcc/ada/einfo.ads | 12 +--
gcc/ada/exp_attr.adb | 1 +
gcc/ada/exp_ch7.adb | 8 +-
gcc/ada/freeze.adb | 29 -------
gcc/ada/gen_il-fields.ads | 2 +-
gcc/ada/gen_il-gen-gen_entities.adb | 2 +-
gcc/ada/gnat_rm.texi | 78 ++++++++-----------
gcc/ada/gnat_ugn.texi | 2 +-
gcc/ada/sem_attr.adb | 8 ++
gcc/ada/sem_ch13.adb | 78 +------------------
gcc/ada/sem_ch6.adb | 61 ++++++++++++++-
gcc/ada/snames.adb-tmpl | 3 +-
gcc/ada/snames.ads-tmpl | 3 +-
15 files changed, 148 insertions(+), 222 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 5d242ed0b1c..d22ebfa5dfa 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -91,7 +91,6 @@ package Aspects is
Aspect_Default_Value,
Aspect_Depends, -- GNAT
Aspect_Designated_Storage_Model, -- GNAT
- Aspect_Destructor, -- GNAT
Aspect_Dimension, -- GNAT
Aspect_Dimension_System, -- GNAT
Aspect_Dispatching_Domain,
@@ -296,7 +295,6 @@ package Aspects is
Aspect_CUDA_Global => True,
Aspect_Depends => True,
Aspect_Designated_Storage_Model => True,
- Aspect_Destructor => True,
Aspect_Dimension => True,
Aspect_Dimension_System => True,
Aspect_Disable_Controlled => True,
@@ -449,7 +447,6 @@ package Aspects is
Aspect_Default_Value => Expression,
Aspect_Depends => Expression,
Aspect_Designated_Storage_Model => Name,
- Aspect_Destructor => Name,
Aspect_Dimension => Expression,
Aspect_Dimension_System => Expression,
Aspect_Dispatching_Domain => Expression,
@@ -554,7 +551,6 @@ package Aspects is
Aspect_Default_Value => True,
Aspect_Depends => False,
Aspect_Designated_Storage_Model => True,
- Aspect_Destructor => False,
Aspect_Dimension => False,
Aspect_Dimension_System => False,
Aspect_Dispatching_Domain => False,
@@ -731,7 +727,6 @@ package Aspects is
Aspect_Default_Value => Name_Default_Value,
Aspect_Depends => Name_Depends,
Aspect_Designated_Storage_Model => Name_Designated_Storage_Model,
- Aspect_Destructor => Name_Destructor,
Aspect_Dimension => Name_Dimension,
Aspect_Dimension_System => Name_Dimension_System,
Aspect_Disable_Controlled => Name_Disable_Controlled,
@@ -1001,7 +996,6 @@ package Aspects is
Aspect_Default_Value => Always_Delay,
Aspect_Default_Component_Value => Always_Delay,
Aspect_Designated_Storage_Model => Always_Delay,
- Aspect_Destructor => Always_Delay,
Aspect_Discard_Names => Always_Delay,
Aspect_Dispatching_Domain => Always_Delay,
Aspect_Dynamic_Predicate => Always_Delay,
diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
index f80ea52d1a1..a30df54170a 100644
--- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
+++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
@@ -1,3 +1,6 @@
+.. role:: ada(code)
+ :language: ada
+
.. _GNAT_Language_Extensions:
************************
@@ -1796,70 +1799,54 @@ configuration that does not exist in standard Ada.
Destructors
-----------
-The ``Destructor`` aspect can be applied to any record type, tagged or not.
-It must denote a primitive of the type that is a procedure with one parameter
-of the type and of mode ``in out``:
+The :ada:`Destructor` extension adds a new finalization mechanism that
+significantly differs standard Ada in how it interacts with type derivation.
+
+New syntax is introduced to make it possible to define "destructors" for record
+types, tagged or untagged. Here's a simple example:
.. code-block:: ada
- type T is record
- ...
- end record with Destructor => Foo;
+ package P is
+ type T is record
+ ...
+ end record;
- procedure Foo (X : in out T);
-
-This is equivalent to the following code that uses ``Finalizable``:
+ procedure T'Destructor (X : in out T);
+ end P;
.. code-block:: ada
- type T is record
- ...
- end record with Finalizable => (Finalize => Foo);
+ package body P is
+ procedure T'Destructor (X : in out T) is
+ begin
+ ...
+ end T'Destructor;
+ end P;
- procedure Foo (X : in out T);
+Like :ada:`Finalize` procedures, destructors are called on objects just before
they
+are destroyed. But destructors are more flexible in how they can used with
derived
+types. With standard Ada finalization, when you derive from a finalizable type,
+you must either inherit the :ada:`Finalize` procedure or override it
completely.
-Unlike ``Finalizable``, however, ``Destructor`` can be specified on a derived
-type. And when it is, the effect of the aspect combines with the destructors of
-the parent type. Take, for example:
+Destructors work differently. You can define a destructor for a type derived
from
+a parent type that also has a destructor, and then when objects of the derived
type
+are finalized, both destructors will be called. For example:
.. code-block:: ada
type T1 is record
...
- end record with Destructor => Foo;
+ end record;
- procedure Foo (X : in out T1);
-
- type T2 is new T1 with Destructor => Bar;
-
- procedure Bar (X : in out T2);
-
-Here, when an object of type ``T2`` is finalized, a call to ``Bar``
-will be performed and it will be followed by a call to ``Foo``.
-
-The ``Destructor`` aspect comes with a legality rule: if a primitive procedure
-of a type is denoted by a ``Destructor`` aspect specification, it is illegal to
-override this procedure in a derived type. For example, the following is
illegal:
-
-.. code-block:: ada
-
- type T1 is record
- ...
- end record with Destructor => Foo;
-
- procedure Foo (X : in out T1);
+ procedure T1'Destructor (X : in out T1);
type T2 is new T1;
- overriding
- procedure Foo (X : in out T2); -- Error here
+ procedure T2'Destructor (X : in out T2);
-It is possible to specify ``Destructor`` on the completion of a private type,
-but there is one more restriction in that case: the denoted primitive must
-be private to the enclosing package. This is necessary due to the previously
-mentioned legality rule, to prevent breaking the privacy of the type when
-imposing that rule on outside types that derive from the private view of the
-type.
+When an object of type :ada:`T2` is finalized, there will be first a call to
+:ada:`T2'Destructor`, and then a call to :ada:`T1'Destructor` on the object.
Structural Generic Instantiation
--------------------------------
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 398424c7b81..43b0e8cb89a 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -919,6 +919,13 @@ package Einfo is
-- incomplete type, and the full type is available, then this full type
-- is returned instead of the incomplete type.
+-- Destructor
+-- Defined in all types and subtypes entities. For record type entities
+-- that have destructors (in the strict sense, i.e., have destructors of
+-- their own and do not just descend from types with destructors), set to
+-- the procedure entity for the destructor. For other entities, set to
+-- Empty.
+
-- DIC_Procedure (synthesized)
-- Defined in all type entities. Set for a private type and its full view
-- when the type is subject to pragma Default_Initial_Condition (DIC), or
@@ -2601,10 +2608,6 @@ package Einfo is
-- Defined in all entities. True if the entity is type System.Address,
-- or (recursively) a subtype or derived type of System.Address.
--- Is_Destructor
--- Defined in procedure entities. True if the procedure is denoted by the
--- Destructor aspect on some type.
-
-- Is_DIC_Procedure
-- Defined in functions and procedures. Set for a generated procedure
-- which verifies the assumption of pragma Default_Initial_Condition at
@@ -6014,7 +6017,6 @@ package Einfo is
-- Is_Constructor
-- Is_CPP_Constructor
-- Is_CUDA_Kernel
- -- Is_Destructor (non-generic case only)
-- Is_DIC_Procedure (non-generic case only)
-- Is_Elaboration_Checks_OK_Id
-- Is_Elaboration_Warnings_OK_Id
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 578e4410e87..9935625f129 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -8717,6 +8717,7 @@ package body Exp_Attr is
| Attribute_Definite
| Attribute_Delta
| Attribute_Denorm
+ | Attribute_Destructor
| Attribute_Digits
| Attribute_Emax
| Attribute_Enabled
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 030134394cb..3ee397a6df4 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -7666,13 +7666,10 @@ package body Exp_Ch7 is
end;
declare
- ASN : constant Opt_N_Aspect_Specification_Id :=
- Get_Rep_Item (Typ, Name_Destructor, False);
-
+ Proc : constant Entity_Id := Destructor (Typ);
Stmt : Node_Id;
- Proc : Entity_Id;
begin
- if Present (ASN) then
+ if Present (Proc) then
-- Generate:
-- begin
-- <Destructor_Proc> (V);
@@ -7686,7 +7683,6 @@ package body Exp_Ch7 is
-- end if;
-- end;
- Proc := Entity (Expression (ASN));
Stmt :=
Make_Procedure_Call_Statement
(Loc,
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 7f5a043cca9..ab04d9733f1 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -7256,35 +7256,6 @@ package body Freeze is
end if;
Inherit_Aspects_At_Freeze_Point (E);
-
- -- Destructor legality check
-
- if Present (Primitive_Operations (E)) then
- declare
- Subp : Entity_Id;
- Parent_Operation : Entity_Id;
-
- Elmt : Elmt_Id := First_Elmt (Primitive_Operations (E));
-
- begin
- while Present (Elmt) loop
- Subp := Node (Elmt);
-
- if Present (Overridden_Operation (Subp)) then
- Parent_Operation := Overridden_Operation (Subp);
-
- if Ekind (Parent_Operation) = E_Procedure
- and then Is_Destructor (Parent_Operation)
- then
- Error_Msg_N ("cannot override destructor", Subp);
- end if;
- end if;
-
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
-
end if;
-- Case of array type
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 8e05c187474..9492c187eb7 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -500,6 +500,7 @@ package Gen_IL.Fields is
Digits_Value,
Predicated_Parent,
Predicates_Ignored,
+ Destructor,
Direct_Primitive_Operations,
Directly_Designated_Type,
Disable_Controlled,
@@ -704,7 +705,6 @@ package Gen_IL.Fields is
Is_CPP_Constructor,
Is_CUDA_Kernel,
Is_Descendant_Of_Address,
- Is_Destructor,
Is_DIC_Procedure,
Is_Discrim_SO_Function,
Is_Discriminant_Check_Function,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb
b/gcc/ada/gen_il-gen-gen_entities.adb
index 1722c7caea5..42f7d055a27 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 (Contract, Node_Id),
Sm (Current_Use_Clause, Node_Id),
Sm (Derived_Type_Link, Node_Id),
+ Sm (Destructor, Node_Id),
Sm (Direct_Primitive_Operations, Elist_Id),
Sm (Predicates_Ignored, Flag),
Sm (Esize, Uint),
@@ -1059,7 +1060,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Is_Asynchronous, Flag),
Sm (Is_Called, Flag),
Sm (Is_CUDA_Kernel, Flag),
- Sm (Is_Destructor, Flag),
Sm (Is_DIC_Procedure, Flag),
Sm (Is_Generic_Actual_Subprogram, Flag),
Sm (Is_Initial_Condition_Procedure, Flag),
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 4b0720b263a..3489747037d 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT Reference Manual , Dec 05, 2025
+GNAT Reference Manual , Jan 09, 2026
AdaCore
@@ -32841,70 +32841,54 @@ configuration that does not exist in standard Ada.
@subsection Destructors
-The @code{Destructor} aspect can be applied to any record type, tagged or not.
-It must denote a primitive of the type that is a procedure with one parameter
-of the type and of mode @code{in out}:
+The @code{Destructor} extension adds a new finalization mechanism that
+significantly differs standard Ada in how it interacts with type derivation.
+
+New syntax is introduced to make it possible to define “destructors” for record
+types, tagged or untagged. Here’s a simple example:
@example
-type T is record
- ...
-end record with Destructor => Foo;
+package P is
+ type T is record
+ ...
+ end record;
-procedure Foo (X : in out T);
+ procedure T'Destructor (X : in out T);
+end P;
@end example
-This is equivalent to the following code that uses @code{Finalizable}:
-
@example
-type T is record
- ...
-end record with Finalizable => (Finalize => Foo);
-
-procedure Foo (X : in out T);
+package body P is
+ procedure T'Destructor (X : in out T) is
+ begin
+ ...
+ end T'Destructor;
+end P;
@end example
-Unlike @code{Finalizable}, however, @code{Destructor} can be specified on a
derived
-type. And when it is, the effect of the aspect combines with the destructors of
-the parent type. Take, for example:
+Like @code{Finalize} procedures, destructors are called on objects just before
they
+are destroyed. But destructors are more flexible in how they can used with
derived
+types. With standard Ada finalization, when you derive from a finalizable type,
+you must either inherit the @code{Finalize} procedure or override it
completely.
+
+Destructors work differently. You can define a destructor for a type derived
from
+a parent type that also has a destructor, and then when objects of the derived
type
+are finalized, both destructors will be called. For example:
@example
type T1 is record
...
-end record with Destructor => Foo;
+end record;
-procedure Foo (X : in out T1);
-
-type T2 is new T1 with Destructor => Bar;
-
-procedure Bar (X : in out T2);
-@end example
-
-Here, when an object of type @code{T2} is finalized, a call to @code{Bar}
-will be performed and it will be followed by a call to @code{Foo}.
-
-The @code{Destructor} aspect comes with a legality rule: if a primitive
procedure
-of a type is denoted by a @code{Destructor} aspect specification, it is
illegal to
-override this procedure in a derived type. For example, the following is
illegal:
-
-@example
-type T1 is record
- ...
-end record with Destructor => Foo;
-
-procedure Foo (X : in out T1);
+procedure T1'Destructor (X : in out T1);
type T2 is new T1;
-overriding
-procedure Foo (X : in out T2); -- Error here
+procedure T2'Destructor (X : in out T2);
@end example
-It is possible to specify @code{Destructor} on the completion of a private
type,
-but there is one more restriction in that case: the denoted primitive must
-be private to the enclosing package. This is necessary due to the previously
-mentioned legality rule, to prevent breaking the privacy of the type when
-imposing that rule on outside types that derive from the private view of the
-type.
+When an object of type @code{T2} is finalized, there will be first a call to
+@code{T2'Destructor}, and then a call to @code{T1'Destructor} on the object.
@node Structural Generic Instantiation,,Destructors,Experimental Language
Extensions
@anchor{gnat_rm/gnat_language_extensions
structural-generic-instantiation}@anchor{479}
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 9edf1aa47f2..e8ed558a62f 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -30269,8 +30269,8 @@ to permit their use in free software.
@printindex ge
-@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{
}
@anchor{d2}@w{ }
+@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{
}
@c %**end of body
@bye
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index de59c6b7771..3ee40c69d94 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -4194,6 +4194,13 @@ package body Sem_Attr is
Set_Etype (N, Universal_Integer);
+ ----------------
+ -- Destructor --
+ ----------------
+
+ when Attribute_Destructor =>
+ Error_Attr_P ("attribute% can only be used to define destructors");
+
------------
-- Digits --
------------
@@ -11183,6 +11190,7 @@ package body Sem_Attr is
| Attribute_Default_Bit_Order
| Attribute_Default_Scalar_Storage_Order
| Attribute_Deref
+ | Attribute_Destructor
| Attribute_Elaborated
| Attribute_Elab_Body
| Attribute_Elab_Spec
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 04f9efc66c5..8624c1d6452 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -4940,20 +4940,6 @@ package body Sem_Ch13 is
goto Continue;
end if;
- when Aspect_Destructor =>
- if not All_Extensions_Allowed then
- Error_Msg_Name_1 := Nam;
- Error_Msg_GNAT_Extension ("aspect %", Loc);
- goto Continue;
-
- elsif not Is_Type (E) then
- Error_Msg_N ("can only be specified for a type", Aspect);
- goto Continue;
- end if;
-
- Set_Has_Destructor (E);
- Set_Is_Controlled_Active (E);
-
when Aspect_Storage_Model_Type =>
if not All_Extensions_Allowed then
Error_Msg_Name_1 := Nam;
@@ -11742,8 +11728,7 @@ package body Sem_Ch13 is
-- name, so we need to verify that one of these interpretations is
-- the one available at the freeze point.
- elsif A_Id in Aspect_Destructor
- | Aspect_Input
+ elsif A_Id in Aspect_Input
| Aspect_Output
| Aspect_Read
| Aspect_Write
@@ -12199,67 +12184,6 @@ package body Sem_Ch13 is
Analyze (Expression (ASN));
return;
- when Aspect_Destructor =>
- if not Is_Record_Type (Entity (ASN)) then
- Error_Msg_N
- ("aspect Destructor can only be specified for a "
- & "record type",
- ASN);
- return;
- end if;
-
- Set_Has_Destructor (Entity (ASN));
- Set_Is_Controlled_Active (Entity (ASN));
-
- Analyze (Expression (ASN));
-
- if not Resolve_Finalization_Procedure
- (Expression (ASN), Entity (ASN))
- then
- Error_Msg_N
- ("destructor must be local procedure whose only formal "
- & "parameter has mode `IN OUT` and is of the type the "
- & "destructor is for",
- Expression (ASN));
- end if;
-
- Set_Is_Destructor (Entity (Expression (ASN)));
-
- declare
- Proc : constant Entity_Id := Entity (Expression (ASN));
- Overr : constant Opt_N_Entity_Id :=
- Overridden_Inherited_Operation (Proc);
- Orig : constant Entity_Id :=
- (if Present (Overr) then Overr else Proc);
-
- Decl : constant Node_Id :=
- Parent
- (if Nkind (Parent (Orig)) = N_Procedure_Specification
- then Parent (Orig)
- else Orig);
-
- Encl : constant Node_Id := Parent (Decl);
-
- Is_Private : constant Boolean :=
- Nkind (Encl) = N_Package_Specification
- and then Is_List_Member (Decl)
- and then List_Containing (Decl) = Private_Declarations (Encl);
-
- begin
-
- if Has_Private_Declaration (Entity (ASN))
- and then not Aspect_On_Partial_View (ASN)
- and then not Is_Private
- then
- Error_Msg_N
- ("aspect Destructor on full view cannot denote public "
- & "primitive",
- ASN);
- end if;
- end;
-
- return;
-
when Aspect_Storage_Model_Type =>
-- The aggregate argument of Storage_Model_Type is optional, and
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 3e40c74da08..d48735a3bd7 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -5280,11 +5280,35 @@ package body Sem_Ch6 is
-----------------------------------------
procedure Analyze_Direct_Attribute_Definition (Designator : Entity_Id) is
+ function Can_Be_Destructor_Of
+ (E : Entity_Id; T : Entity_Id) return Boolean;
+ -- Returns whether E can be declared the destructor of T
+
+ --------------------------
+ -- Can_Be_Destructor_Of --
+ --------------------------
+
+ function Can_Be_Destructor_Of
+ (E : Entity_Id; T : Entity_Id) return Boolean is
+ begin
+ return
+ Ekind (E) = E_Procedure
+ and then Scope (E) = Scope (T)
+ and then Present (First_Formal (E))
+ and then Ekind (First_Formal (E)) = E_In_Out_Parameter
+ and then Etype (First_Formal (E)) = T
+ and then No (Next_Formal (First_Formal (E)));
+ end Can_Be_Destructor_Of;
+
+ -- Local variables
+
Att_N : constant Node_Id := Original_Node (N);
Prefix_E : constant Entity_Id :=
Get_Name_Entity_Id (Chars (Prefix (Defining_Unit_Name (Att_N))));
Att_Name : constant Name_Id :=
Attribute_Name (Defining_Unit_Name (Att_N));
+
+ -- Start of processing for Analyze_Direct_Attribute_Definition
begin
pragma Assert (N /= Att_N);
@@ -5341,7 +5365,7 @@ package body Sem_Ch6 is
("& must be defined before freezing#", Designator);
elsif Parent_Kind (Enclosing_Package_Or_Subprogram (Designator))
- /= N_Package_Specification
+ /= N_Package_Specification
then
Error_Msg_N
("& is required to be a primitive operation", Designator);
@@ -5351,7 +5375,40 @@ package body Sem_Ch6 is
Set_Is_Constructor (Designator);
end if;
- when others =>
+ when Name_Destructor =>
+ if Parent_Kind (N) not in N_Subprogram_Declaration then
+ return;
+ elsif not Is_Record_Type (Prefix_E) then
+ Error_Msg_N
+ ("destructors can only be specified for record types",
+ Designator);
+ return;
+ elsif not Can_Be_Destructor_Of (Designator, Prefix_E) then
+ Error_Msg_N
+ ("destructor must be local procedure whose only formal "
+ & "parameter has mode `IN OUT` and is of the type the "
+ & "destructor is for",
+ Designator);
+ elsif Is_Frozen (Prefix_E)
+ or else Current_Scope /= Scope (Prefix_E)
+ then
+ Error_Msg_Sloc := Sloc (Freeze_Node (Prefix_E));
+ Error_Msg_N
+ ("& must be defined before freezing#", Designator);
+
+ elsif Parent_Kind (Enclosing_Package_Or_Subprogram (Designator))
+ /= N_Package_Specification
+ then
+ Error_Msg_N
+ ("& is required to be a primitive operation", Designator);
+
+ else
+ Set_Has_Destructor (Prefix_E);
+ Set_Is_Controlled_Active (Prefix_E);
+ Set_Destructor (Prefix_E, Designator);
+ end if;
+
+ when others =>
null;
end case;
diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl
index b5f53cd4749..91075eaa330 100644
--- a/gcc/ada/snames.adb-tmpl
+++ b/gcc/ada/snames.adb-tmpl
@@ -418,7 +418,8 @@ package body Snames is
function Is_Direct_Attribute_Definition_Name (N : Name_Id) return Boolean is
begin
- return Is_Attribute_Name (N) and then N = Name_Constructor;
+ return
+ Is_Attribute_Name (N) and then N in Name_Constructor | Name_Destructor;
end Is_Direct_Attribute_Definition_Name;
------------------------------
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index cb07f97c4fe..4d129269fef 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -150,7 +150,6 @@ package Snames is
Name_Default_Value : constant Name_Id := N + $;
Name_Default_Component_Value : constant Name_Id := N + $;
Name_Designated_Storage_Model : constant Name_Id := N + $;
- Name_Destructor : constant Name_Id := N + $;
Name_Dimension : constant Name_Id := N + $;
Name_Dimension_System : constant Name_Id := N + $;
Name_Disable_Controlled : constant Name_Id := N + $;
@@ -964,6 +963,7 @@ package Snames is
Name_Denorm : constant Name_Id := N + $;
Name_Deref : constant Name_Id := N + $; -- GNAT
Name_Descriptor_Size : constant Name_Id := N + $;
+ Name_Destructor : constant Name_Id := N + $;
Name_Digits : constant Name_Id := N + $;
Name_Elaborated : constant Name_Id := N + $; -- GNAT
Name_Emax : constant Name_Id := N + $; -- Ada 83
@@ -1509,6 +1509,7 @@ package Snames is
Attribute_Denorm,
Attribute_Deref,
Attribute_Descriptor_Size,
+ Attribute_Destructor,
Attribute_Digits,
Attribute_Elaborated,
Attribute_Emax,
--
2.51.0
