summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gnat.dg/align_max.adb
blob: 26597ea9661e2baed05e22ea35e98efa8ec10996 (plain)
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;