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