1--  { dg-do run }
2
3with System.Storage_Elements; use System.Storage_Elements;
4with Ada.Unchecked_Deallocation;
5
6procedure 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
49begin
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;
136end;
137
138