From: Ronan Desplanques <desplanq...@adacore.com>

This patch adds a GNAT-specific extension which enables "destructors".
Destructors are an optional replacement for Ada.Finalization where some
aspects of the interaction with type derivation are different.

gcc/ada/ChangeLog:

        * doc/gnat_rm/gnat_language_extensions.rst: Document new extension.
        * snames.ads-tmpl: Add name for new aspect.
        * gen_il-fields.ads (Has_Destructor, Is_Destructor): Add new fields.
        * gen_il-gen-gen_entities.adb (E_Procedure, Type_Kind): Add new fields.
        * einfo.ads (Has_Destructor, Is_Destructor): Document new fields.
        * aspects.ads: Add new aspect.
        * sem_ch13.adb (Analyze_Aspect_Specifications,
        Check_Aspect_At_Freeze_Point, Check_Aspect_At_End_Of_Declarations):
        Add semantic analysis for new aspect.
        (Resolve_Finalization_Procedure): New function.
        (Resolve_Finalizable_Argument): Use new function above.
        * sem_util.adb (Propagate_Controlled_Flags): Extend for new field.
        * freeze.adb (Freeze_Entity): Add legality check for new aspect.
        * exp_ch3.adb (Expand_Freeze_Record_Type, Predefined_Primitive_Bodies):
        Use new field.
        * exp_ch7.adb (Build_Finalize_Statements): Add expansion for
        destructors.
        (Make_Final_Call, Build_Record_Deep_Procs): Adapt to new Has_Destructor
        field.
        (Build_Adjust_Statements): Tweak to handle cases of empty lists.
        * gnat_rm.texi: Regenerate.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/aspects.ads                           |   6 +
 .../doc/gnat_rm/gnat_language_extensions.rst  |  68 +++++++++
 gcc/ada/einfo.ads                             |  21 ++-
 gcc/ada/exp_ch3.adb                           |  38 ++---
 gcc/ada/exp_ch7.adb                           | 130 ++++++++++++++---
 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                          | 138 +++++++++++++-----
 gcc/ada/sem_ch13.adb                          | 138 +++++++++++++++---
 gcc/ada/sem_util.adb                          |   4 +
 gcc/ada/snames.ads-tmpl                       |   1 +
 12 files changed, 479 insertions(+), 98 deletions(-)

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 6d37ec7bf2a..737f1513606 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -92,6 +92,7 @@ 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,
@@ -294,6 +295,7 @@ 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,
@@ -448,6 +450,7 @@ 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,
@@ -552,6 +555,7 @@ 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,
@@ -727,6 +731,7 @@ 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,
@@ -995,6 +1000,7 @@ 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 f31317942c2..ff111ddd3a1 100644
--- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
+++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
@@ -1793,3 +1793,71 @@ statement in the sequence of statements of the specified 
loop_statement.
 
 Note that ``continue`` is a keyword but it is not a reserved word. This is a
 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;
+
+   procedure Foo (X : in out T);
+
+This is equivalent to the following code that uses ``Finalizable``:
+
+.. code-block:: ada
+
+   type T is record
+      ...
+   end record with Finalizable => (Finalize => Foo);
+
+   procedure Foo (X : in out T);
+
+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:
+
+.. 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);
+
+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);
+
+   type T2 is new T1;
+
+   overriding
+   procedure Foo (X : in out T2); -- Error here
+
+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.
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index b23cd9e8c27..225f0fa0fcc 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1595,6 +1595,11 @@ package Einfo is
 --       set, signalling that Freeze.Inherit_Delayed_Rep_Aspects must be called
 --       at the freeze point of the derived type.
 
+--    Has_Destructor
+--       Defined in all type and subtype entities. Set only for record type
+--       entities for which at least one ancestor has the Destructor aspect
+--       specified.
+
 --    Has_DIC (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
@@ -2523,11 +2528,12 @@ package Einfo is
 
 --    Is_Controlled_Active [base type only]
 --       Defined in all type entities. Indicates that the type is controlled,
---       i.e. has been declared with the Finalizable aspect or has inherited
---       the Finalizable aspect from an ancestor. Can only be set for record
---       types, tagged or untagged. System.Finalization_Root.Root_Controlled
---       is an example of the former case while Ada.Finalization.Controlled
---       and Ada.Finalization.Limited_Controlled are examples of the latter.
+--       i.e. has been declared with the Finalizable or the Destructor aspect
+--       or has inherited the this aspect from an ancestor. Can only be set for
+--       record types, tagged or untagged.
+--       System.Finalization_Root.Root_Controlled is an example of the former
+--       case while Ada.Finalization.Controlled and
+--       Ada.Finalization.Limited_Controlled are examples of the latter.
 
 --    Is_Controlled (synth) [base type only]
 --       Defined in all type entities. Set if Is_Controlled_Active is set for
@@ -2553,6 +2559,10 @@ 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
@@ -5932,6 +5942,7 @@ package Einfo is
    --    Is_Class_Wide_Wrapper
    --    Is_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_ch3.adb b/gcc/ada/exp_ch3.adb
index c7dfb0d62ae..5bb4a25a715 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6498,7 +6498,7 @@ package body Exp_Ch3 is
          end;
       end if;
 
-      if Has_Controlled_Component (Typ) then
+      if Has_Controlled_Component (Typ) or else Has_Destructor (Typ) then
          Build_Controlling_Procs (Typ);
       end if;
 
@@ -12846,25 +12846,27 @@ package body Exp_Ch3 is
             Append_To (Res, Decl);
          end if;
 
-         Fin_Call := Empty;
-         Decl     := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
+         if not Has_Destructor (Tag_Typ) then
+            Fin_Call := Empty;
+            Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
 
-         if Is_Controlled (Tag_Typ) then
-            Fin_Call :=
-              Make_Final_Call
-                (Obj_Ref => Make_Identifier (Loc, Name_V),
-                 Typ     => Tag_Typ);
+            if Is_Controlled (Tag_Typ) then
+               Fin_Call :=
+                 Make_Final_Call
+                   (Obj_Ref => Make_Identifier (Loc, Name_V), Typ => Tag_Typ);
+            end if;
+
+            if No (Fin_Call) then
+               Fin_Call := Make_Null_Statement (Loc);
+            end if;
+
+            Set_Handled_Statement_Sequence
+              (Decl,
+               Make_Handled_Sequence_Of_Statements
+                 (Loc, Statements => New_List (Fin_Call)));
+
+            Append_To (Res, Decl);
          end if;
-
-         if No (Fin_Call) then
-            Fin_Call := Make_Null_Statement (Loc);
-         end if;
-
-         Set_Handled_Statement_Sequence (Decl,
-           Make_Handled_Sequence_Of_Statements (Loc,
-             Statements => New_List (Fin_Call)));
-
-         Append_To (Res, Decl);
       end if;
 
       return Res;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 9b88491d58f..dd864b7ffd3 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -3589,18 +3589,22 @@ package body Exp_Ch7 is
 
    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
    begin
-      Set_TSS (Typ,
-        Make_Deep_Proc
-          (Prim  => Initialize_Case,
-           Typ   => Typ,
-           Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
+      if Has_Controlled_Component (Typ) then
+         Set_TSS
+           (Typ,
+            Make_Deep_Proc
+              (Prim  => Initialize_Case,
+               Typ   => Typ,
+               Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
 
-      if not Is_Inherently_Limited_Type (Typ) then
-         Set_TSS (Typ,
-           Make_Deep_Proc
-             (Prim  => Adjust_Case,
-              Typ   => Typ,
-              Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
+         if not Is_Inherently_Limited_Type (Typ) then
+            Set_TSS
+              (Typ,
+               Make_Deep_Proc
+                 (Prim  => Adjust_Case,
+                  Typ   => Typ,
+                  Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
+         end if;
       end if;
 
       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
@@ -6641,6 +6645,16 @@ package body Exp_Ch7 is
       --       Raised : Boolean := False;
       --
       --    begin
+      --       begin
+      --          <Destructor_Proc> (V);  --  If applicable
+      --       exception
+      --          when others =>
+      --             if not Raised then
+      --                Raised := True;
+      --                Save_Occurrence (E, Get_Current_Excep.all.all);
+      --             end if;
+      --       end;
+      --
       --       if F then
       --          begin
       --             Finalize (V);  --  If applicable
@@ -6696,6 +6710,8 @@ package body Exp_Ch7 is
       --
       --       begin
       --          Deep_Finalize (V._parent, False);  --  If applicable
+      --  or
+      --          Deep_Finalize (Parent_Type (V), False); -- Untagged case
       --       exception
       --          when Id : others =>
       --             if not Raised then
@@ -7100,7 +7116,7 @@ package body Exp_Ch7 is
          --  or the type is not controlled.
 
          if Is_Empty_List (Bod_Stmts) then
-            Append_To (Bod_Stmts, Make_Null_Statement (Loc));
+            Append_New_To (Bod_Stmts, Make_Null_Statement (Loc));
 
             return Bod_Stmts;
 
@@ -7587,9 +7603,13 @@ package body Exp_Ch7 is
 
          --    Deep_Finalize (Obj._parent, False);
 
-         if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
+         if Is_Derived_Type (Typ) then
             declare
-               Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
+               Tagd     : constant Boolean := Is_Tagged_Type (Typ);
+               Par_Typ  : constant Entity_Id :=
+                 (if Tagd
+                  then Parent_Field_Type (Typ)
+                  else Etype (Base_Type (Typ)));
                Call     : Node_Id;
                Fin_Stmt : Node_Id;
 
@@ -7598,10 +7618,16 @@ package body Exp_Ch7 is
                   Call :=
                     Make_Final_Call
                       (Obj_Ref   =>
-                         Make_Selected_Component (Loc,
-                           Prefix        => Make_Identifier (Loc, Name_V),
-                           Selector_Name =>
-                             Make_Identifier (Loc, Name_uParent)),
+                         (if Tagd
+                          then
+                            Make_Selected_Component
+                              (Loc,
+                               Prefix        => Make_Identifier (Loc, Name_V),
+                               Selector_Name =>
+                                 Make_Identifier (Loc, Name_uParent))
+                          else
+                            Convert_To
+                              (Par_Typ, Make_Identifier (Loc, Name_V))),
                        Typ       => Par_Typ,
                        Skip_Self => True);
 
@@ -7609,6 +7635,21 @@ package body Exp_Ch7 is
                   --    begin
                   --       Deep_Finalize (V._parent, False);
 
+                  --    exception
+                  --       when Id : others =>
+                  --          if not Raised then
+                  --             Raised := True;
+                  --             Save_Occurrence (E,
+                  --               Get_Current_Excep.all.all);
+                  --          end if;
+                  --    end;
+                  --
+                  --  in the tagged case. In the untagged case, which arises
+                  --  with the Destructor aspect, generate:
+                  --
+                  --    begin
+                  --       Deep_Finalize (Parent_Type (V), False);
+
                   --    exception
                   --       when Id : others =>
                   --          if not Raised then
@@ -7662,7 +7703,7 @@ package body Exp_Ch7 is
                         --  than before, the extension components. That might
                         --  be more intuitive (as discussed in preceding
                         --  comment), but it is not required.
-                        Prepend_To (Bod_Stmts, Fin_Stmt);
+                        Prepend_New_To (Bod_Stmts, Fin_Stmt);
                      end if;
                   end if;
                end if;
@@ -7713,12 +7754,58 @@ package body Exp_Ch7 is
                                  (Finalizer_Data))));
                   end if;
 
-                  Prepend_To (Bod_Stmts,
+                  Prepend_New_To (Bod_Stmts,
                     Make_If_Statement (Loc,
                       Condition       => Make_Identifier (Loc, Name_F),
                       Then_Statements => New_List (Fin_Stmt)));
                end if;
             end;
+
+            declare
+               ASN : constant Opt_N_Aspect_Specification_Id :=
+                 Get_Rep_Item (Typ, Name_Destructor, False);
+
+               Stmt : Node_Id;
+               Proc : Entity_Id;
+            begin
+               if Present (ASN) then
+                  --  Generate:
+                  --    begin
+                  --       <Destructor_Proc> (V);
+
+                  --    exception
+                  --       when others =>
+                  --          if not Raised then
+                  --             Raised := True;
+                  --             Save_Occurrence (E,
+                  --               Get_Current_Excep.all.all);
+                  --          end if;
+                  --    end;
+
+                  Proc := Entity (Expression (ASN));
+                  Stmt :=
+                    Make_Procedure_Call_Statement
+                      (Loc,
+                       Name                   => New_Occurrence_Of (Proc, Loc),
+                       Parameter_Associations =>
+                         New_List (Make_Identifier (Loc, Name_V)));
+                  if Exceptions_OK then
+                     Stmt :=
+                       Make_Block_Statement
+                         (Loc,
+                          Handled_Statement_Sequence =>
+                            Make_Handled_Sequence_Of_Statements
+                              (Loc,
+                               Statements         => New_List (Stmt),
+                               Exception_Handlers =>
+                                 New_List
+                                   (Build_Exception_Handler
+                                      (Finalizer_Data))));
+                  end if;
+
+                  Prepend_New_To (Bod_Stmts, Stmt);
+               end if;
+            end;
          end if;
 
          --  At this point either all finalization statements have been
@@ -7972,7 +8059,7 @@ package body Exp_Ch7 is
          return Empty;
 
       elsif Skip_Self then
-         if Has_Controlled_Component (Utyp) then
+         if Has_Controlled_Component (Utyp) or else Has_Destructor (Utyp) then
             if Is_Tagged_Type (Utyp) then
                Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
             else
@@ -7985,6 +8072,7 @@ package body Exp_Ch7 is
       elsif Is_Class_Wide_Type (Typ)
         or else Is_Interface (Typ)
         or else Has_Controlled_Component (Utyp)
+        or else Has_Destructor (Utyp)
       then
          if Is_Tagged_Type (Utyp) then
             Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index c47b884701a..dbd7cf425a2 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -7231,6 +7231,35 @@ 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 dd4b1a081b3..a1e284f14e4 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -575,6 +575,7 @@ package Gen_IL.Fields is
       Has_Delayed_Aspects,
       Has_Delayed_Freeze,
       Has_Delayed_Rep_Aspects,
+      Has_Destructor,
       Has_Discriminants,
       Has_Dispatch_Table,
       Has_Dynamic_Predicate_Aspect,
@@ -702,6 +703,7 @@ package Gen_IL.Fields is
       Is_CPP_Class,
       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 e05d8b50430..0fedfbc6099 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -467,6 +467,7 @@ begin -- Gen_IL.Gen.Gen_Entities
         Sm (Full_View, Node_Id),
         Sm (Has_Completion_In_Body, Flag),
         Sm (Has_Constrained_Partial_View, Flag, Base_Type_Only),
+        Sm (Has_Destructor, Flag, Base_Type_Only),
         Sm (Has_Discriminants, Flag),
         Sm (Has_Dispatch_Table, Flag,
             Pre => "Is_Tagged_Type (N)"),
@@ -1055,6 +1056,7 @@ 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 b0a14b034bc..1ca3ede355b 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -19,7 +19,7 @@
 
 @copying
 @quotation
-GNAT Reference Manual , Jul 03, 2025
+GNAT Reference Manual , Jul 21, 2025
 
 AdaCore
 
@@ -931,6 +931,7 @@ Experimental Language Extensions
 * External_Initialization Aspect:: 
 * Finally construct:: 
 * Continue statement:: 
+* Destructors:: 
 
 Storage Model
 
@@ -31236,6 +31237,7 @@ Features activated via @code{-gnatX0} or
 * External_Initialization Aspect:: 
 * Finally construct:: 
 * Continue statement:: 
+* Destructors:: 
 
 @end menu
 
@@ -32588,7 +32590,7 @@ Abort/ATC (asynchronous transfer of control) cannot 
interrupt a finally block, n
 execution, that is the finally block must be executed in full even if the 
containing task is
 aborted, or if the control is transferred out of the block.
 
-@node Continue statement,,Finally construct,Experimental Language Extensions
+@node Continue statement,Destructors,Finally construct,Experimental Language 
Extensions
 @anchor{gnat_rm/gnat_language_extensions continue-statement}@anchor{472}
 @subsection Continue statement
 
@@ -32606,8 +32608,78 @@ statement in the sequence of statements of the 
specified loop_statement.
 Note that @code{continue} is a keyword but it is not a reserved word. This is a
 configuration that does not exist in standard Ada.
 
+@node Destructors,,Continue statement,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions destructors}@anchor{473}
+@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}:
+
+@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}:
+
+@example
+type T is record
+   ...
+end record with Finalizable => (Finalize => Foo);
+
+procedure Foo (X : in out T);
+@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);
+@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);
+
+type T2 is new T1;
+
+overriding
+procedure Foo (X : in out T2); -- Error here
+@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.
+
 @node Security Hardening Features,Obsolescent Features,GNAT language 
extensions,Top
-@anchor{gnat_rm/security_hardening_features 
doc}@anchor{473}@anchor{gnat_rm/security_hardening_features 
id1}@anchor{474}@anchor{gnat_rm/security_hardening_features 
security-hardening-features}@anchor{15}
+@anchor{gnat_rm/security_hardening_features 
doc}@anchor{474}@anchor{gnat_rm/security_hardening_features 
id1}@anchor{475}@anchor{gnat_rm/security_hardening_features 
security-hardening-features}@anchor{15}
 @chapter Security Hardening Features
 
 
@@ -32629,7 +32701,7 @@ change.
 @end menu
 
 @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{475}
+@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{476}
 @section Register Scrubbing
 
 
@@ -32665,7 +32737,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{476}
+@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{477}
 @section Stack Scrubbing
 
 
@@ -32809,7 +32881,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{477}
+@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{478}
 @section Hardened Conditionals
 
 
@@ -32899,7 +32971,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{478}
+@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{479}
 @section Hardened Booleans
 
 
@@ -32960,7 +33032,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{479}
+@anchor{gnat_rm/security_hardening_features 
control-flow-redundancy}@anchor{47a}
 @section Control Flow Redundancy
 
 
@@ -33128,7 +33200,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{47a}@anchor{gnat_rm/obsolescent_features 
id1}@anchor{47b}@anchor{gnat_rm/obsolescent_features 
obsolescent-features}@anchor{16}
+@anchor{gnat_rm/obsolescent_features 
doc}@anchor{47b}@anchor{gnat_rm/obsolescent_features 
id1}@anchor{47c}@anchor{gnat_rm/obsolescent_features 
obsolescent-features}@anchor{16}
 @chapter Obsolescent Features
 
 
@@ -33147,7 +33219,7 @@ compatibility purposes.
 @end menu
 
 @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features 
id2}@anchor{47c}@anchor{gnat_rm/obsolescent_features 
pragma-no-run-time}@anchor{47d}
+@anchor{gnat_rm/obsolescent_features 
id2}@anchor{47d}@anchor{gnat_rm/obsolescent_features 
pragma-no-run-time}@anchor{47e}
 @section pragma No_Run_Time
 
 
@@ -33160,7 +33232,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{47e}@anchor{gnat_rm/obsolescent_features 
pragma-ravenscar}@anchor{47f}
+@anchor{gnat_rm/obsolescent_features 
id3}@anchor{47f}@anchor{gnat_rm/obsolescent_features 
pragma-ravenscar}@anchor{480}
 @section pragma Ravenscar
 
 
@@ -33169,7 +33241,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{480}@anchor{gnat_rm/obsolescent_features 
pragma-restricted-run-time}@anchor{481}
+@anchor{gnat_rm/obsolescent_features 
id4}@anchor{481}@anchor{gnat_rm/obsolescent_features 
pragma-restricted-run-time}@anchor{482}
 @section pragma Restricted_Run_Time
 
 
@@ -33179,7 +33251,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{482}@anchor{gnat_rm/obsolescent_features 
pragma-task-info}@anchor{483}
+@anchor{gnat_rm/obsolescent_features 
id5}@anchor{483}@anchor{gnat_rm/obsolescent_features 
pragma-task-info}@anchor{484}
 @section pragma Task_Info
 
 
@@ -33205,7 +33277,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{484}@anchor{gnat_rm/obsolescent_features 
package-system-task-info-s-tasinf-ads}@anchor{485}
+@anchor{gnat_rm/obsolescent_features 
package-system-task-info}@anchor{485}@anchor{gnat_rm/obsolescent_features 
package-system-task-info-s-tasinf-ads}@anchor{486}
 @section package System.Task_Info (@code{s-tasinf.ads})
 
 
@@ -33215,7 +33287,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{486}@anchor{gnat_rm/compatibility_and_porting_guide 
compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide
 id1}@anchor{487}
+@anchor{gnat_rm/compatibility_and_porting_guide 
doc}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide 
compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide
 id1}@anchor{488}
 @chapter Compatibility and Porting Guide
 
 
@@ -33237,7 +33309,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{488}@anchor{gnat_rm/compatibility_and_porting_guide 
writing-portable-fixed-point-declarations}@anchor{489}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id2}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide 
writing-portable-fixed-point-declarations}@anchor{48a}
 @section Writing Portable Fixed-Point Declarations
 
 
@@ -33359,7 +33431,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{48a}@anchor{gnat_rm/compatibility_and_porting_guide
 id3}@anchor{48b}
+@anchor{gnat_rm/compatibility_and_porting_guide 
compatibility-with-ada-83}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide
 id3}@anchor{48c}
 @section Compatibility with Ada 83
 
 
@@ -33387,7 +33459,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{48c}@anchor{gnat_rm/compatibility_and_porting_guide 
legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48d}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id4}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide 
legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48e}
 @subsection Legal Ada 83 programs that are illegal in Ada 95
 
 
@@ -33487,7 +33559,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{48e}@anchor{gnat_rm/compatibility_and_porting_guide 
more-deterministic-semantics}@anchor{48f}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id5}@anchor{48f}@anchor{gnat_rm/compatibility_and_porting_guide 
more-deterministic-semantics}@anchor{490}
 @subsection More deterministic semantics
 
 
@@ -33515,7 +33587,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{490}@anchor{gnat_rm/compatibility_and_porting_guide 
id6}@anchor{491}
+@anchor{gnat_rm/compatibility_and_porting_guide 
changed-semantics}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide 
id6}@anchor{492}
 @subsection Changed semantics
 
 
@@ -33557,7 +33629,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{492}@anchor{gnat_rm/compatibility_and_porting_guide 
other-language-compatibility-issues}@anchor{493}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id7}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide 
other-language-compatibility-issues}@anchor{494}
 @subsection Other language compatibility issues
 
 
@@ -33590,7 +33662,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{494}@anchor{gnat_rm/compatibility_and_porting_guide
 id8}@anchor{495}
+@anchor{gnat_rm/compatibility_and_porting_guide 
compatibility-between-ada-95-and-ada-2005}@anchor{495}@anchor{gnat_rm/compatibility_and_porting_guide
 id8}@anchor{496}
 @section Compatibility between Ada 95 and Ada 2005
 
 
@@ -33662,7 +33734,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{496}@anchor{gnat_rm/compatibility_and_porting_guide 
implementation-dependent-characteristics}@anchor{497}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id9}@anchor{497}@anchor{gnat_rm/compatibility_and_porting_guide 
implementation-dependent-characteristics}@anchor{498}
 @section Implementation-dependent characteristics
 
 
@@ -33685,7 +33757,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{498}@anchor{gnat_rm/compatibility_and_porting_guide 
implementation-defined-pragmas}@anchor{499}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id10}@anchor{499}@anchor{gnat_rm/compatibility_and_porting_guide 
implementation-defined-pragmas}@anchor{49a}
 @subsection Implementation-defined pragmas
 
 
@@ -33707,7 +33779,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{49a}@anchor{gnat_rm/compatibility_and_porting_guide 
implementation-defined-attributes}@anchor{49b}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id11}@anchor{49b}@anchor{gnat_rm/compatibility_and_porting_guide 
implementation-defined-attributes}@anchor{49c}
 @subsection Implementation-defined attributes
 
 
@@ -33721,7 +33793,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{49c}@anchor{gnat_rm/compatibility_and_porting_guide 
libraries}@anchor{49d}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id12}@anchor{49d}@anchor{gnat_rm/compatibility_and_porting_guide 
libraries}@anchor{49e}
 @subsection Libraries
 
 
@@ -33750,7 +33822,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{49e}@anchor{gnat_rm/compatibility_and_porting_guide 
id13}@anchor{49f}
+@anchor{gnat_rm/compatibility_and_porting_guide 
elaboration-order}@anchor{49f}@anchor{gnat_rm/compatibility_and_porting_guide 
id13}@anchor{4a0}
 @subsection Elaboration order
 
 
@@ -33786,7 +33858,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{4a0}@anchor{gnat_rm/compatibility_and_porting_guide 
target-specific-aspects}@anchor{4a1}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id14}@anchor{4a1}@anchor{gnat_rm/compatibility_and_porting_guide 
target-specific-aspects}@anchor{4a2}
 @subsection Target-specific aspects
 
 
@@ -33799,10 +33871,10 @@ on the robustness of the original design.  Moreover, 
Ada 95 (and thus
 Ada 2005, Ada 2012, and Ada 2022) 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{4a2,,Representation 
Clauses}.
+GNAT’s approach to these issues is described in @ref{4a3,,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{4a3}@anchor{gnat_rm/compatibility_and_porting_guide
 id15}@anchor{4a4}
+@anchor{gnat_rm/compatibility_and_porting_guide 
compatibility-with-other-ada-systems}@anchor{4a4}@anchor{gnat_rm/compatibility_and_porting_guide
 id15}@anchor{4a5}
 @section Compatibility with Other Ada Systems
 
 
@@ -33845,7 +33917,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{4a5}@anchor{gnat_rm/compatibility_and_porting_guide 
representation-clauses}@anchor{4a2}
+@anchor{gnat_rm/compatibility_and_porting_guide 
id16}@anchor{4a6}@anchor{gnat_rm/compatibility_and_porting_guide 
representation-clauses}@anchor{4a3}
 @section Representation Clauses
 
 
@@ -33938,7 +34010,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{4a6}@anchor{gnat_rm/compatibility_and_porting_guide
 id17}@anchor{4a7}
+@anchor{gnat_rm/compatibility_and_porting_guide 
compatibility-with-hp-ada-83}@anchor{4a7}@anchor{gnat_rm/compatibility_and_porting_guide
 id17}@anchor{4a8}
 @section Compatibility with HP Ada 83
 
 
@@ -33968,7 +34040,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{4a8}@anchor{share/gnu_free_documentation_license 
gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license 
gnu-free-documentation-license}@anchor{4a9}
+@anchor{share/gnu_free_documentation_license 
doc}@anchor{4a9}@anchor{share/gnu_free_documentation_license 
gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license 
gnu-free-documentation-license}@anchor{4aa}
 @chapter GNU Free Documentation License
 
 
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 162de654323..b7ada50456a 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -337,6 +337,13 @@ package body Sem_Ch13 is
    --  Resolve each one of the arguments specified in the specification of
    --  aspect Finalizable.
 
+   function Resolve_Finalization_Procedure
+     (N   : Node_Id;
+      Typ : Entity_Id) return Boolean;
+   --  Resolve a procedure argument specified in the specification of one of
+   --  the finalization aspects, i.e. Finalizable and Destructor. Returns True
+   --  if successful, False otherwise.
+
    procedure Resolve_Iterable_Operation
      (N      : Node_Id;
       Cursor : Entity_Id;
@@ -4647,6 +4654,20 @@ 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;
@@ -11285,6 +11306,7 @@ package body Sem_Ch13 is
       --  the one available at at the freeze point.
 
       elsif A_Id in Aspect_Constructor
+                  | Aspect_Destructor
                   | Aspect_Input
                   | Aspect_Output
                   | Aspect_Read
@@ -11742,6 +11764,67 @@ 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
@@ -17343,6 +17426,35 @@ package body Sem_Ch13 is
      (N   : Node_Id;
       Typ : Entity_Id;
       Nam : Name_Id)
+   is
+   begin
+      if Nam = Name_Relaxed_Finalization then
+         Resolve (N, Any_Boolean);
+
+         if Is_OK_Static_Expression (N) then
+            Set_Has_Relaxed_Finalization (Typ, Is_True (Static_Boolean (N)));
+
+         else
+            Flag_Non_Static_Expr
+              ("expression of aspect Finalizable must be static!", N);
+         end if;
+
+         return;
+      end if;
+
+      if Resolve_Finalization_Procedure (N, Typ) then
+         return;
+      end if;
+
+      Error_Msg_N
+        ("finalizable primitive must be local procedure whose only formal " &
+         "parameter has mode `IN OUT` and is of the finalizable type", N);
+   end Resolve_Finalizable_Argument;
+
+   function Resolve_Finalization_Procedure
+     (N   : Node_Id;
+      Typ : Entity_Id)
+      return Boolean
    is
       function Is_Finalizable_Primitive (E : Entity_Id) return Boolean;
       --  Check whether E is a finalizable primitive for Typ
@@ -17361,29 +17473,15 @@ package body Sem_Ch13 is
            and then No (Next_Formal (First_Formal (E)));
       end Is_Finalizable_Primitive;
 
-   --  Start of processing for Resolve_Finalizable_Argument
+   --  Start of processing for Resolve_Finalization_Procedure
 
    begin
-      if Nam = Name_Relaxed_Finalization then
-         Resolve (N, Any_Boolean);
-
-         if Is_OK_Static_Expression (N) then
-            Set_Has_Relaxed_Finalization (Typ, Is_True (Static_Boolean (N)));
-
-         else
-            Flag_Non_Static_Expr
-              ("expression of aspect Finalizable must be static!", N);
-         end if;
-
-         return;
-      end if;
-
       if not Is_Entity_Name (N) then
          null;
 
       elsif not Is_Overloaded (N) then
          if Is_Finalizable_Primitive (Entity (N)) then
-            return;
+            return True;
          end if;
 
       else
@@ -17399,7 +17497,7 @@ package body Sem_Ch13 is
             while Present (It.Typ) loop
                if Is_Finalizable_Primitive (It.Nam) then
                   Set_Entity (N, It.Nam);
-                  return;
+                  return True;
                end if;
 
                Get_Next_Interp (I, It);
@@ -17407,10 +17505,8 @@ package body Sem_Ch13 is
          end;
       end if;
 
-      Error_Msg_N
-        ("finalizable primitive must be local procedure whose only formal " &
-         "parameter has mode `IN OUT` and is of the finalizable type", N);
-   end Resolve_Finalizable_Argument;
+      return False;
+   end Resolve_Finalization_Procedure;
 
    --------------------------------
    -- Resolve_Iterable_Operation --
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 8ceba7318a9..b2b4fed8c1e 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -26970,6 +26970,10 @@ package body Sem_Util is
       if Has_Relaxed_Finalization (From_Typ) then
          Set_Has_Relaxed_Finalization (Typ);
       end if;
+
+      if Deriv and then Has_Destructor (From_Typ) then
+         Set_Has_Destructor (Typ);
+      end if;
    end Propagate_Controlled_Flags;
 
    ------------------------------
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index f26515e75ea..272e10ba1d5 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -151,6 +151,7 @@ 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 + $;
-- 
2.43.0

Reply via email to