gcc/testsuite/gnat.dg/tagged_alloc_free.adb

   1 -- { dg-do run }
   2
   3 with Ada.Unchecked_Deallocation;
   4 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
   5
   6 procedure Tagged_Alloc_Free is
   7
   8   type Test_Base is tagged null record;
   9   type Test_Class_Access is access all Test_Base'Class;
  10   type Test_Extension is new Test_Base with record
  11     Last_Name : Unbounded_String := Null_Unbounded_String;
  12   end record;
  13
  14   procedure Free is new Ada.Unchecked_Deallocation
  15     (Object => Test_Base'Class,
  16      Name   => Test_Class_Access);
  17
  18   Handle : Test_Class_Access := new Test_Extension;
  19
  20 begin
  21   Free (Handle);
  22 end;