OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gnat.dg/] [unc_memops.adb] - Blame information for rev 304

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 304 jeremybenn
 
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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.