1-- { dg-do run }
2
3with Text_IO; use Text_IO;
4with Ada.Finalization; use Ada.Finalization;
5
6procedure Nested_Controlled_Alloc is
7
8   package Controlled_Alloc is
9
10      type Fin is new Limited_Controlled with null record;
11      procedure Finalize (X : in out Fin);
12
13      F : Fin;
14
15      type T is limited private;
16      type Ref is access all T;
17
18   private
19
20      type T is new Limited_Controlled with null record;
21      procedure Finalize (X : in out T);
22
23   end Controlled_Alloc;
24
25   package body Controlled_Alloc is
26
27       procedure Finalize (X : in out T) is
28       begin
29          Put_Line ("Finalize (T)");
30       end Finalize;
31
32       procedure Finalize (X : in out Fin) is
33          R : Ref;
34       begin
35          begin
36             R := new T;
37             raise Constraint_Error;
38
39          exception
40             when Program_Error =>
41                null;  -- OK
42          end;
43       end Finalize;
44
45   end Controlled_Alloc;
46
47begin
48   null;
49end Nested_Controlled_Alloc;
50