summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gnat.dg/nested_controlled_alloc.adb
blob: 963ba76be9718d72f50d69667d87b36008df69f4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
-- { dg-do run }

with Text_IO; use Text_IO;
with Ada.Finalization; use Ada.Finalization;

procedure Nested_Controlled_Alloc is
   
   package Controlled_Alloc is

      type Fin is new Limited_Controlled with null record;
      procedure Finalize (X : in out Fin);

      F : Fin;
      
      type T is limited private;
      type Ref is access all T;
   
   private
      
      type T is new Limited_Controlled with null record;
      procedure Finalize (X : in out T);
   
   end Controlled_Alloc;
   
   package body Controlled_Alloc is

       procedure Finalize (X : in out T) is
       begin
          Put_Line ("Finalize (T)");
       end Finalize;

       procedure Finalize (X : in out Fin) is
          R : Ref;
       begin
          begin
             R := new T;
             raise Constraint_Error;
          
          exception
             when Program_Error =>
                null;  -- OK
          end;
       end Finalize;
   
   end Controlled_Alloc;

begin
   null;
end Nested_Controlled_Alloc;