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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
-- { 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;
|
