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/] [align_max.adb] - Blame information for rev 304

Details | Compare with Previous | View Log


--  { dg-do run }
 
with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Deallocation;
 
procedure Align_MAX is
 
   Align : constant := Standard'Maximum_Alignment;
 
   generic
      type Data_Type (<>) is private;
      type Access_Type is access Data_Type;
      with function Allocate return Access_Type;
      with function Address (Ptr : Access_Type) return System.Address;
   package Check is
      --  The hooks below just force asm generation that helps associating
      --  obscure nested function names with their package instance name.
      Hook_Allocate : System.Address := Allocate'Address;
      Hook_Address : System.Address := Address'Address;
      pragma Volatile (Hook_Allocate);
      pragma Volatile (Hook_Address);
 
      procedure Run (Announce : String);
   end;
 
   package body Check is
 
      procedure Free is new
        Ada.Unchecked_Deallocation (Data_Type, Access_Type);
 
      procedure Run (Announce : String) is
         Addr : System.Address;
         Blocks : array (1 .. 1024) of Access_Type;
      begin
         for J in Blocks'Range loop
            Blocks (J) := Allocate;
            Addr := Address (Blocks (J));
            if Addr mod Data_Type'Alignment /= 0 then
               raise Program_Error;
            end if;
         end loop;
 
         for J in Blocks'Range loop
            Free (Blocks (J));
         end loop;
      end;
   end;
 
begin
   declare
      type Array_Type is array (Integer range <>) of Integer;
      for Array_Type'Alignment use Align;
 
      type FAT_Array_Access is access all Array_Type;
 
      function Allocate return FAT_Array_Access is
      begin
         return new Array_Type (1 .. 1);
      end;
 
      function Address (Ptr : FAT_Array_Access) return System.Address is
      begin
         return Ptr(1)'Address;
      end;
      package Check_FAT is new
        Check (Array_Type, FAT_Array_Access, Allocate, Address);
   begin
      Check_FAT.Run ("Checking FAT pointer to UNC array");
   end;
 
   declare
      type Array_Type is array (Integer range <>) of Integer;
      for Array_Type'Alignment use Align;
 
      type THIN_Array_Access is access all Array_Type;
      for THIN_Array_Access'Size use Standard'Address_Size;
 
      function Allocate return THIN_Array_Access is
      begin
         return new Array_Type (1 .. 1);
      end;
 
      function Address (Ptr : THIN_Array_Access) return System.Address is
      begin
         return Ptr(1)'Address;
      end;
      package Check_THIN is new
        Check (Array_Type, THIN_Array_Access, Allocate, Address);
   begin
      Check_THIN.Run ("Checking THIN pointer to UNC array");
   end;
 
   declare
      type Array_Type is array (Integer range 1 .. 1) of Integer;
      for Array_Type'Alignment use Align;
 
      type Array_Access is access all Array_Type;
 
      function Allocate return Array_Access is
      begin
         return new Array_Type;
      end;
 
      function Address (Ptr : Array_Access) return System.Address is
      begin
         return Ptr(1)'Address;
      end;
      package Check_Array is new
        Check (Array_Type, Array_Access, Allocate, Address);
   begin
      Check_Array.Run ("Checking pointer to constrained array");
   end;
 
   declare
      type Record_Type is record
         Value : Integer;
      end record;
      for Record_Type'Alignment use Align;
 
      type Record_Access is access all Record_Type;
 
      function Allocate return Record_Access is
      begin
         return new Record_Type;
      end;
 
      function Address (Ptr : Record_Access) return System.Address is
      begin
         return Ptr.all'Address;
      end;
      package Check_Record is new
        Check (Record_Type, Record_Access, Allocate, Address);
   begin
      Check_Record.Run ("Checking pointer to record");
   end;
end;
 

Line No.	Rev	Author	Line
1	304	jeremybenn	`-- { dg-do run }`
2
3			`with System.Storage_Elements; use System.Storage_Elements;`
4			`with Ada.Unchecked_Deallocation;`
5
6			`procedure Align_MAX is`
7
8			`Align : constant := Standard'Maximum_Alignment;`
9
10			`generic`
11			`type Data_Type (<>) is private;`
12			`type Access_Type is access Data_Type;`
13			`with function Allocate return Access_Type;`
14			`with function Address (Ptr : Access_Type) return System.Address;`
15			`package Check is`
16			`-- The hooks below just force asm generation that helps associating`
17			`-- obscure nested function names with their package instance name.`
18			`Hook_Allocate : System.Address := Allocate'Address;`
19			`Hook_Address : System.Address := Address'Address;`
20			`pragma Volatile (Hook_Allocate);`
21			`pragma Volatile (Hook_Address);`
22
23			`procedure Run (Announce : String);`
24			`end;`
25
26			`package body Check is`
27
28			`procedure Free is new`
29			`Ada.Unchecked_Deallocation (Data_Type, Access_Type);`
30
31			`procedure Run (Announce : String) is`
32			`Addr : System.Address;`
33			`Blocks : array (1 .. 1024) of Access_Type;`
34			`begin`
35			`for J in Blocks'Range loop`
36			`Blocks (J) := Allocate;`
37			`Addr := Address (Blocks (J));`
38			`if Addr mod Data_Type'Alignment /= 0 then`
39			`raise Program_Error;`
40			`end if;`
41			`end loop;`
42
43			`for J in Blocks'Range loop`
44			`Free (Blocks (J));`
45			`end loop;`
46			`end;`
47			`end;`
48
49			`begin`
50			`declare`
51			`type Array_Type is array (Integer range <>) of Integer;`
52			`for Array_Type'Alignment use Align;`
53
54			`type FAT_Array_Access is access all Array_Type;`
55
56			`function Allocate return FAT_Array_Access is`
57			`begin`
58			`return new Array_Type (1 .. 1);`
59			`end;`
60
61			`function Address (Ptr : FAT_Array_Access) return System.Address is`
62			`begin`
63			`return Ptr(1)'Address;`
64			`end;`
65			`package Check_FAT is new`
66			`Check (Array_Type, FAT_Array_Access, Allocate, Address);`
67			`begin`
68			`Check_FAT.Run ("Checking FAT pointer to UNC array");`
69			`end;`
70
71			`declare`
72			`type Array_Type is array (Integer range <>) of Integer;`
73			`for Array_Type'Alignment use Align;`
74
75			`type THIN_Array_Access is access all Array_Type;`
76			`for THIN_Array_Access'Size use Standard'Address_Size;`
77
78			`function Allocate return THIN_Array_Access is`
79			`begin`
80			`return new Array_Type (1 .. 1);`
81			`end;`
82
83			`function Address (Ptr : THIN_Array_Access) return System.Address is`
84			`begin`
85			`return Ptr(1)'Address;`
86			`end;`
87			`package Check_THIN is new`
88			`Check (Array_Type, THIN_Array_Access, Allocate, Address);`
89			`begin`
90			`Check_THIN.Run ("Checking THIN pointer to UNC array");`
91			`end;`
92
93			`declare`
94			`type Array_Type is array (Integer range 1 .. 1) of Integer;`
95			`for Array_Type'Alignment use Align;`
96
97			`type Array_Access is access all Array_Type;`
98
99			`function Allocate return Array_Access is`
100			`begin`
101			`return new Array_Type;`
102			`end;`
103
104			`function Address (Ptr : Array_Access) return System.Address is`
105			`begin`
106			`return Ptr(1)'Address;`
107			`end;`
108			`package Check_Array is new`
109			`Check (Array_Type, Array_Access, Allocate, Address);`
110			`begin`
111			`Check_Array.Run ("Checking pointer to constrained array");`
112			`end;`
113
114			`declare`
115			`type Record_Type is record`
116			`Value : Integer;`
117			`end record;`
118			`for Record_Type'Alignment use Align;`
119
120			`type Record_Access is access all Record_Type;`
121
122			`function Allocate return Record_Access is`
123			`begin`
124			`return new Record_Type;`
125			`end;`
126
127			`function Address (Ptr : Record_Access) return System.Address is`
128			`begin`
129			`return Ptr.all'Address;`
130			`end;`
131			`package Check_Record is new`
132			`Check (Record_Type, Record_Access, Allocate, Address);`
133			`begin`
134			`Check_Record.Run ("Checking pointer to record");`
135			`end;`
136			`end;`
137

Browse

Tools

Subversion Repositories openrisc_me

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