gcc/testsuite/gnat.dg/unc_memops.adb

   1
   2 package body Unc_Memops is
   3
   4    use type System.Address;
   5
   6    type Addr_Array_T is array (1 .. 20) of Addr_T;
   7
   8    type Addr_Stack_T is record
   9       Store : Addr_Array_T;
  10       Size  : Integer := 0;
  11    end record;
  12
  13    procedure Push (Addr : Addr_T; As : access addr_stack_t) is
  14    begin
  15       As.Size := As.Size + 1;
  16       As.Store (As.Size) := Addr;
  17    end;
  18
  19    function Pop (As : access Addr_Stack_T) return Addr_T is
  20       Addr : Addr_T := As.Store (As.Size);
  21    begin
  22       As.Size := As.Size - 1;
  23       return Addr;
  24    end;
  25
  26    --
  27
  28    Addr_Stack : aliased Addr_Stack_T;
  29    Symetry_Expected : Boolean := False;
  30
  31    procedure Expect_Symetry (Status : Boolean) is
  32    begin
  33       Symetry_Expected := Status;
  34    end;
  35
  36    function  Alloc (Size : size_t) return Addr_T is
  37       function malloc (Size : Size_T) return Addr_T;
  38       pragma Import (C, Malloc, "malloc");
  39
  40       Ptr : Addr_T := malloc (Size);
  41    begin
  42       if Symetry_Expected then
  43          Push (Ptr, Addr_Stack'Access);
  44       end if;
  45       return Ptr;
  46    end;
  47
  48    procedure Free (Ptr : addr_t) is
  49    begin
  50       if Symetry_Expected
  51         and then Ptr /= Pop (Addr_Stack'Access)
  52       then
  53          raise Program_Error;
  54       end if;
  55    end;
  56
  57    function  Realloc (Ptr  : addr_t; Size : size_t) return Addr_T is
  58    begin
  59       raise Program_Error;
  60       return System.Null_Address;
  61    end;
  62
  63 end;