gcc/testsuite/gnat.dg/no_final.adb

   1 -- { dg-do run }
   2
   3 pragma Restrictions (No_Finalization);
   4 procedure no_final is
   5    package P is
   6       type T is tagged null record;
   7       type T1 is new T with record
   8          A : String (1..80);
   9       end record;
  10       function F return T'Class;
  11    end P;
  12
  13    Str : String (1..80) := (1..80=>'x');
  14
  15    package body P is
  16       function F return T'Class is
  17          X : T1 := T1'(A => Str);
  18       begin
  19          return X;
  20       end F;
  21    end P;
  22
  23    Obj : P.T'class := P.F;
  24 begin
  25    if P.T1 (Obj).A /= Str then
  26       raise Constraint_Error;
  27    end if;
  28 end;
  29