https://gcc.gnu.org/g:08c63732c8e69229e21d467246ebb60abd02e989

commit r16-6612-g08c63732c8e69229e21d467246ebb60abd02e989
Author: Ronan Desplanques <[email protected]>
Date:   Tue Dec 2 12:48:04 2025 +0100

    ada: Change syntax for destructors extension
    
    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.

Diff:
---
 gcc/ada/aspects.ads                              |  6 --
 gcc/ada/doc/gnat_rm/gnat_language_extensions.rst | 75 ++++++++++-------------
 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                             | 74 +++++++++-------------
 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, 145 insertions(+), 219 deletions(-)

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 5d242ed0b1c1..d22ebfa5dfaa 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 f80ea52d1a16..a30df54170a3 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``:
-
-.. code-block:: ada
-
-   type T is record
-      ...
-   end record with Destructor => Foo;
+The :ada:`Destructor` extension adds a new finalization mechanism that
+significantly differs standard Ada in how it interacts with type derivation.
 
-   procedure Foo (X : in out T);
-
-This is equivalent to the following code that uses ``Finalizable``:
+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 Finalizable => (Finalize => Foo);
-
-   procedure Foo (X : in out T);
+   package P is
+      type T is record
+         ...
+      end record;
 
-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:
+      procedure T'Destructor (X : in out T);
+   end P;
 
 .. code-block:: ada
 
-   type T1 is record
-      ...
-   end record with Destructor => Foo;
-
-   procedure Foo (X : in out T1);
-
-   type T2 is new T1 with Destructor => Bar;
-
-   procedure Bar (X : in out T2);
+   package body P is
+      procedure T'Destructor (X : in out T) is
+      begin
+         ...
+      end T'Destructor;
+   end P;
 
-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``.
+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.
 
-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:
+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);
+   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 398424c7b810..43b0e8cb89a8 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 578e4410e878..9935625f1299 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 030134394cb3..3ee397a6df44 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 7f5a043cca9e..ab04d9733f1d 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 8e05c187474d..9492c187eb78 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 1722c7caea5d..42f7d055a27c 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 4b0720b263ae..3489747037d7 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.
 
-@example
-type T is record
-   ...
-end record with Destructor => Foo;
-
-procedure Foo (X : in out T);
-@end example
-
-This is equivalent to the following code that uses @code{Finalizable}:
+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 Finalizable => (Finalize => 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
 
-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:
-
 @example
-type T1 is record
-   ...
-end record with Destructor => Foo;
-
-procedure Foo (X : in out T1);
-
-type T2 is new T1 with Destructor => Bar;
-
-procedure Bar (X : in out T2);
+package body P is
+   procedure T'Destructor (X : in out T) is
+   begin
+      ...
+   end T'Destructor;
+end P;
 @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}.
+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.
 
-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:
+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);
+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 9edf1aa47f21..e8ed558a62fd 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 de59c6b77713..3ee40c69d94f 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 04f9efc66c55..8624c1d64521 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 3e40c74da083..d48735a3bd77 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 b5f53cd47493..91075eaa3307 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 cb07f97c4fe2..4d129269fef7 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,

Reply via email to