nested_controlled_alloc.adb

来自「用于进行gcc测试」· ADB 代码 · 共 50 行

-- { 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;