gcc/testsuite/gnat.dg/align_max.adb

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