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

Details | Compare with Previous | View Log

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
 

powered by: WebSVN 2.1.0

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