3 with System.Storage_Elements; use System.Storage_Elements;
4 with Ada.Unchecked_Deallocation;
8 Align : constant := Standard'Maximum_Alignment;
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;
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);
23 procedure Run (Announce : String);
29 Ada.Unchecked_Deallocation (Data_Type, Access_Type);
31 procedure Run (Announce : String) is
32 Addr : System.Address;
33 Blocks : array (1 .. 1024) of Access_Type;
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
43 for J in Blocks'Range loop
51 type Array_Type is array (Integer range <>) of Integer;
52 for Array_Type'Alignment use Align;
54 type FAT_Array_Access is access all Array_Type;
56 function Allocate return FAT_Array_Access is
58 return new Array_Type (1 .. 1);
61 function Address (Ptr : FAT_Array_Access) return System.Address is
63 return Ptr(1)'Address;
65 package Check_FAT is new
66 Check (Array_Type, FAT_Array_Access, Allocate, Address);
68 Check_FAT.Run ("Checking FAT pointer to UNC array");
72 type Array_Type is array (Integer range <>) of Integer;
73 for Array_Type'Alignment use Align;
75 type THIN_Array_Access is access all Array_Type;
76 for THIN_Array_Access'Size use Standard'Address_Size;
78 function Allocate return THIN_Array_Access is
80 return new Array_Type (1 .. 1);
83 function Address (Ptr : THIN_Array_Access) return System.Address is
85 return Ptr(1)'Address;
87 package Check_THIN is new
88 Check (Array_Type, THIN_Array_Access, Allocate, Address);
90 Check_THIN.Run ("Checking THIN pointer to UNC array");
94 type Array_Type is array (Integer range 1 .. 1) of Integer;
95 for Array_Type'Alignment use Align;
97 type Array_Access is access all Array_Type;
99 function Allocate return Array_Access is
101 return new Array_Type;
104 function Address (Ptr : Array_Access) return System.Address is
106 return Ptr(1)'Address;
108 package Check_Array is new
109 Check (Array_Type, Array_Access, Allocate, Address);
111 Check_Array.Run ("Checking pointer to constrained array");
115 type Record_Type is record
118 for Record_Type'Alignment use Align;
120 type Record_Access is access all Record_Type;
122 function Allocate return Record_Access is
124 return new Record_Type;
127 function Address (Ptr : Record_Access) return System.Address is
129 return Ptr.all'Address;
131 package Check_Record is new
132 Check (Record_Type, Record_Access, Allocate, Address);
134 Check_Record.Run ("Checking pointer to record");