gcc/testsuite/gnat.dg/array_bounds_test2.adb

   1 --  { dg-do run }
   2
   3 with Ada.Unchecked_Deallocation;
   4
   5 procedure Array_Bounds_Test2 is
   6
   7   type String_Ptr_T is access String;
   8   procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr_T);
   9   String_Data : String_Ptr_T := new String'("Hello World");
  10
  11   function Peek return String_Ptr_T is
  12   begin
  13     return String_Data;
  14   end Peek;
  15
  16 begin
  17   declare
  18     Corrupted_String : String := Peek.all;
  19   begin
  20     Free(String_Data);
  21     if Corrupted_String'First /= 1 then
  22       raise Program_Error;
  23     end if;
  24   end;
  25 end;