summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gnat.dg/unc_memops.adb
blob: 356fc01002d94c1171a278b714ee42291f21e419 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
package body Unc_Memops is

   use type System.Address;

   type Addr_Array_T is array (1 .. 20) of Addr_T;

   type Addr_Stack_T is record
      Store : Addr_Array_T;
      Size  : Integer := 0;
   end record;

   procedure Push (Addr : Addr_T; As : access addr_stack_t) is
   begin
      As.Size := As.Size + 1;
      As.Store (As.Size) := Addr;
   end;

   function Pop (As : access Addr_Stack_T) return Addr_T is
      Addr : Addr_T := As.Store (As.Size);
   begin
      As.Size := As.Size - 1;
      return Addr;
   end;

   --

   Addr_Stack : aliased Addr_Stack_T;
   Symetry_Expected : Boolean := False;

   procedure Expect_Symetry (Status : Boolean) is
   begin
      Symetry_Expected := Status;
   end;

   function  Alloc (Size : size_t) return Addr_T is
      function malloc (Size : Size_T) return Addr_T;
      pragma Import (C, Malloc, "malloc");

      Ptr : Addr_T := malloc (Size);
   begin
      if Symetry_Expected then
         Push (Ptr, Addr_Stack'Access);
      end if;
      return Ptr;
   end;

   procedure Free (Ptr : addr_t) is
   begin
      if Symetry_Expected
        and then Ptr /= Pop (Addr_Stack'Access)
      then
         raise Program_Error;
      end if;
   end;

   function  Realloc (Ptr  : addr_t; Size : size_t) return Addr_T is
   begin
      raise Program_Error;
      return System.Null_Address;
   end;

end;