gcc/testsuite/gnat.dg/nested_controlled_alloc.adb

   1 -- { dg-do run }
   2
   3 with Text_IO; use Text_IO;
   4 with Ada.Finalization; use Ada.Finalization;
   5
   6 procedure 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
  47 begin
  48    null;
  49 end Nested_Controlled_Alloc;