mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-22 11:31:05 +08:00
Code Issues Packages Projects Releases Wiki Activity

utils2.c (build_call_alloc_dealloc_proc): New helper for build_call_alloc_dealloc with arguments to be interpreted...

Browse Source 
ada/
        * gcc-interface/utils2.c (build_call_alloc_dealloc_proc): New
        helper for build_call_alloc_dealloc with arguments to be interpreted
        identically.  Process the case where a GNAT_PROC to call is provided.
        (maybe_wrap_malloc): New helper for build_call_alloc_dealloc, to build
        and return an allocator for DATA_SIZE bytes aimed at containing a
        DATA_TYPE object, using the default __gnat_malloc allocator.  Honor
        DATA_TYPE alignments greater than what the latter offers.
        (maybe_wrap_free): New helper for build_call_alloc_dealloc, to
        release a DATA_TYPE object designated by DATA_PTR using the
        __gnat_free entry point.
        (build_call_alloc_dealloc): Expect object data type instead of naked
        alignment constraint. Use the new helpers.
        (build_allocator): Remove special processing for the super-aligned
        case, now handled by build_call_alloc_dealloc.  Pass data type instead
        of the former alignment argument, as expected by the new interface.
        * gcc-interface/gigi.h (build_call_alloc_dealloc): Adjust prototype
        and comment.
        * gcc-interface/trans.c (gnat_to_gnu) <case N_Free_Statement>:
        Remove special processing for the super-aligned case, now handled
        by build_call_alloc_dealloc.  Pass data type instead of the former
        alignment argument, as expected by the new interface.

        testsuite/
        * gnat.dg/align_max.adb: New test.

From-SVN: r148314
This commit is contained in:
Olivier Hainque 2009-06-09 15:32:03 +00:00 committed by Olivier Hainque
parent 6aa0b21841
commit ff346f7075
6 changed files with 383 additions and 193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/ada/ChangeLog
View File

@ -1,3 +1,28 @@
2009-06-09 Olivier Hainque <hainque@adacore.com>
* gcc-interface/utils2.c (build_call_alloc_dealloc_proc): New
helper for build_call_alloc_dealloc with arguments to be interpreted
identically. Process the case where a GNAT_PROC to call is provided.
(maybe_wrap_malloc): New helper for build_call_alloc_dealloc, to build
and return an allocator for DATA_SIZE bytes aimed at containing a
DATA_TYPE object, using the default __gnat_malloc allocator. Honor
DATA_TYPE alignments greater than what the latter offers.
(maybe_wrap_free): New helper for build_call_alloc_dealloc, to
release a DATA_TYPE object designated by DATA_PTR using the
__gnat_free entry point.
(build_call_alloc_dealloc): Expect object data type instead of naked
alignment constraint. Use the new helpers.
(build_allocator): Remove special processing for the super-aligned
case, now handled by build_call_alloc_dealloc. Pass data
type instead of the former alignment argument, as expected by the new
interface.
* gcc-interface/gigi.h (build_call_alloc_dealloc): Adjust prototype
and comment.
* gcc-interface/trans.c (gnat_to_gnu) <case N_Free_Statement>:
Remove special processing for the super-aligned case, now handled
by build_call_alloc_dealloc. Pass data type instead of the former
alignment argument, as expected by the new interface.
2009-06-08 Alexandre Oliva <aoliva@redhat.com>
* lib-writ.adb (flag_compare_debug): Import.

12
gcc/ada/gcc-interface/gigi.h
View File

@ -843,13 +843,13 @@ extern tree build_component_ref (tree record_variable, tree component,
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
generate an allocator.
GNU_SIZE is the size of the object in bytes and ALIGN is the alignment
in bits. GNAT_PROC, if present, is a procedure to call and GNAT_POOL
is the storage pool to use. If not present, malloc and free are used.
GNAT_NODE is used to provide an error location for restriction violation
messages. */
GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
object type, used to determine the to-be-honored address alignment.
GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
pool to use. If not present, malloc and free are used. GNAT_NODE is used
to provide an error location for restriction violation messages. */
extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size,
unsigned align, Entity_Id gnat_proc,
tree gnu_type, Entity_Id gnat_proc,
Entity_Id gnat_pool, Node_Id gnat_node);
/* Build a GCC tree to correspond to allocating an object of TYPE whose

45
gcc/ada/gcc-interface/trans.c
View File

@ -5101,9 +5101,6 @@ gnat_to_gnu (Node_Id gnat_node)
tree gnu_obj_type;
tree gnu_actual_obj_type = 0;
tree gnu_obj_size;
unsigned int align;
unsigned int default_allocator_alignment
= get_target_default_allocator_alignment () * BITS_PER_UNIT;
/* If this is a thin pointer, we must dereference it to create
a fat pointer, then go back below to a thin pointer. The
@ -5142,7 +5139,6 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_actual_obj_type = gnu_obj_type;
gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
align = TYPE_ALIGN (gnu_obj_type);
if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
@ -5159,42 +5155,11 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_ptr, gnu_byte_offset);
}
/* If the object was allocated from the default storage pool, the
alignment was greater than what the allocator provides, and this
is not a fat or thin pointer, what we have in gnu_ptr here is an
address dynamically adjusted to match the alignment requirement
(see build_allocator). What we need to pass to free is the
initial allocator's return value, which has been stored just in
front of the block we have. */
if (No (Procedure_To_Call (gnat_node))
&& align > default_allocator_alignment
&& ! TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
{
/* We set GNU_PTR
as * (void **)((void *)GNU_PTR - (void *)sizeof(void *))
in two steps: */
/* GNU_PTR (void *)
= (void *)GNU_PTR - (void *)sizeof (void *)) */
gnu_ptr
= build_binary_op
(POINTER_PLUS_EXPR, ptr_void_type_node,
convert (ptr_void_type_node, gnu_ptr),
size_int (-POINTER_SIZE/BITS_PER_UNIT));
/* GNU_PTR (void *) = *(void **)GNU_PTR */
gnu_ptr
= build_unary_op
(INDIRECT_REF, NULL_TREE,
convert (build_pointer_type (ptr_void_type_node),
gnu_ptr));
}
gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
Procedure_To_Call (gnat_node),
Storage_Pool (gnat_node),
gnat_node);
gnu_result
= build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
Procedure_To_Call (gnat_node),
Storage_Pool (gnat_node),
gnat_node);
}
break;

353
gcc/ada/gcc-interface/utils2.c
View File

@ -1830,95 +1830,99 @@ build_component_ref (tree record_variable, tree component,
N_Raise_Constraint_Error));
}
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
generate an allocator.
/* Helper for build_call_alloc_dealloc, with arguments to be interpreted
identically. Process the case where a GNAT_PROC to call is provided. */
GNU_SIZE is the size of the object in bytes and ALIGN is the alignment
in bits. GNAT_PROC, if present, is a procedure to call and GNAT_POOL
is the storage pool to use. If not present, malloc and free are used.
GNAT_NODE is used to provide an error location for restriction violation
messages. */
tree
build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
Entity_Id gnat_proc, Entity_Id gnat_pool,
Node_Id gnat_node)
static inline tree
build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
Entity_Id gnat_proc, Entity_Id gnat_pool)
{
tree gnu_align = size_int (align / BITS_PER_UNIT);
tree gnu_proc = gnat_to_gnu (gnat_proc);
tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
tree gnu_call;
gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
if (Present (gnat_proc))
/* The storage pools are obviously always tagged types, but the
secondary stack uses the same mechanism and is not tagged. */
if (Is_Tagged_Type (Etype (gnat_pool)))
{
/* The storage pools are obviously always tagged types, but the
secondary stack uses the same mechanism and is not tagged. */
if (Is_Tagged_Type (Etype (gnat_pool)))
{
/* The size is the third parameter; the alignment is the
same type. */
Entity_Id gnat_size_type
= Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
tree gnu_proc = gnat_to_gnu (gnat_proc);
tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
tree gnu_pool = gnat_to_gnu (gnat_pool);
tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
tree gnu_call;
/* The size is the third parameter; the alignment is the
same type. */
Entity_Id gnat_size_type
= Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
gnu_size = convert (gnu_size_type, gnu_size);
gnu_align = convert (gnu_size_type, gnu_align);
tree gnu_pool = gnat_to_gnu (gnat_pool);
tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
/* The first arg is always the address of the storage pool; next
comes the address of the object, for a deallocator, then the
size and alignment. */
if (gnu_obj)
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 4, gnu_pool_addr,
gnu_obj, gnu_size, gnu_align);
else
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 3, gnu_pool_addr,
gnu_size, gnu_align);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
gnu_size = convert (gnu_size_type, gnu_size);
gnu_align = convert (gnu_size_type, gnu_align);
/* Secondary stack case. */
/* The first arg is always the address of the storage pool; next
comes the address of the object, for a deallocator, then the
size and alignment. */
if (gnu_obj)
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 4, gnu_pool_addr,
gnu_obj, gnu_size, gnu_align);
else
{
/* The size is the second parameter. */
Entity_Id gnat_size_type
= Etype (Next_Formal (First_Formal (gnat_proc)));
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
tree gnu_proc = gnat_to_gnu (gnat_proc);
tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
tree gnu_call;
gnu_size = convert (gnu_size_type, gnu_size);
/* The first arg is the address of the object, for a deallocator,
then the size. */
if (gnu_obj)
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 2, gnu_obj, gnu_size);
else
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 1, gnu_size);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 3, gnu_pool_addr,
gnu_size, gnu_align);
}
if (gnu_obj)
return build_call_1_expr (free_decl, gnu_obj);
/* Secondary stack case. */
else
{
/* The size is the second parameter. */
Entity_Id gnat_size_type
= Etype (Next_Formal (First_Formal (gnat_proc)));
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
/* Assert that we no longer can be called with this special pool. */
gcc_assert (gnat_pool != -1);
gnu_size = convert (gnu_size_type, gnu_size);
/* Check that we aren't violating the associated restriction. */
if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
Check_No_Implicit_Heap_Alloc (gnat_node);
/* The first arg is the address of the object, for a deallocator,
then the size. */
if (gnu_obj)
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 2, gnu_obj, gnu_size);
else
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 1, gnu_size);
}
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
/* Helper for build_call_alloc_dealloc, to build and return an allocator for
DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default
__gnat_malloc allocator. Honor DATA_TYPE alignments greater than what the
latter offers. */
static inline tree
maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
{
/* When the DATA_TYPE alignment is stricter than what malloc offers
(super-aligned case), we allocate an "aligning" wrapper type and return
the address of its single data field with the malloc's return value
stored just in front. */
unsigned int data_align = TYPE_ALIGN (data_type);
unsigned int default_allocator_alignment
= get_target_default_allocator_alignment () * BITS_PER_UNIT;
tree aligning_type
= ((data_align > default_allocator_alignment)
? make_aligning_type (data_type, data_align, data_size,
default_allocator_alignment,
POINTER_SIZE / BITS_PER_UNIT)
: NULL_TREE);
tree size_to_malloc
= aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
tree malloc_ptr;
/* On VMS, if 64-bit memory is disabled or pointers are 64-bit and the
allocator size is 32-bit or Convention C, allocate 32-bit memory. */
@ -1927,9 +1931,127 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
|| (POINTER_SIZE == 64
&& (UI_To_Int (Esize (Etype (gnat_node))) == 32
|| Convention (Etype (gnat_node)) == Convention_C))))
return build_call_1_expr (malloc32_decl, gnu_size);
malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc);
else
malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc);
return build_call_1_expr (malloc_decl, gnu_size);
if (aligning_type)
{
/* Latch malloc's return value and get a pointer to the aligning field
first. */
tree storage_ptr = save_expr (malloc_ptr);
tree aligning_record_addr
= convert (build_pointer_type (aligning_type), storage_ptr);
tree aligning_record
= build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr);
tree aligning_field
= build_component_ref (aligning_record, NULL_TREE,
TYPE_FIELDS (aligning_type), 0);
tree aligning_field_addr
= build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
/* Then arrange to store the allocator's return value ahead
and return. */
tree storage_ptr_slot_addr
= build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
convert (ptr_void_type_node, aligning_field_addr),
size_int (-POINTER_SIZE/BITS_PER_UNIT));
tree storage_ptr_slot
= build_unary_op (INDIRECT_REF, NULL_TREE,
convert (build_pointer_type (ptr_void_type_node),
storage_ptr_slot_addr));
return
build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr),
build_binary_op (MODIFY_EXPR, NULL_TREE,
storage_ptr_slot, storage_ptr),
aligning_field_addr);
}
else
return malloc_ptr;
}
/* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object
designated by DATA_PTR using the __gnat_free entry point. */
static inline tree
maybe_wrap_free (tree data_ptr, tree data_type)
{
/* In the regular alignment case, we pass the data pointer straight to free.
In the superaligned case, we need to retrieve the initial allocator
return value, stored in front of the data block at allocation time. */
unsigned int data_align = TYPE_ALIGN (data_type);
unsigned int default_allocator_alignment
= get_target_default_allocator_alignment () * BITS_PER_UNIT;
tree free_ptr;
if (data_align > default_allocator_alignment)
{
/* DATA_FRONT_PTR (void *)
= (void *)DATA_PTR - (void *)sizeof (void *)) */
tree data_front_ptr
= build_binary_op
(POINTER_PLUS_EXPR, ptr_void_type_node,
convert (ptr_void_type_node, data_ptr),
size_int (-POINTER_SIZE/BITS_PER_UNIT));
/* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR */
free_ptr
= build_unary_op
(INDIRECT_REF, NULL_TREE,
convert (build_pointer_type (ptr_void_type_node), data_front_ptr));
}
else
free_ptr = data_ptr;
return build_call_1_expr (free_decl, free_ptr);
}
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
generate an allocator.
GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
object type, used to determine the to-be-honored address alignment.
GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
pool to use. If not present, malloc and free are used. GNAT_NODE is used
to provide an error location for restriction violation messages. */
tree
build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
Entity_Id gnat_proc, Entity_Id gnat_pool,
Node_Id gnat_node)
{
gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
/* Explicit proc to call ? This one is assumed to deal with the type
alignment constraints. */
if (Present (gnat_proc))
return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type,
gnat_proc, gnat_pool);
/* Otherwise, object to "free" or "malloc" with possible special processing
for alignments stricter than what the default allocator honors. */
else if (gnu_obj)
return maybe_wrap_free (gnu_obj, gnu_type);
else
{
/* Assert that we no longer can be called with this special pool. */
gcc_assert (gnat_pool != -1);
/* Check that we aren't violating the associated restriction. */
if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
Check_No_Implicit_Heap_Alloc (gnat_node);
return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
}
}
/* Build a GCC tree to correspond to allocating an object of TYPE whose
@ -1949,8 +2071,6 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
{
tree size = TYPE_SIZE_UNIT (type);
tree result;
unsigned int default_allocator_alignment
= get_target_default_allocator_alignment () * BITS_PER_UNIT;
/* If the initializer, if present, is a NULL_EXPR, just return a new one. */
if (init && TREE_CODE (init) == NULL_EXPR)
@ -1977,8 +2097,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
size = ssize_int (-1);
storage = build_call_alloc_dealloc (NULL_TREE, size,
TYPE_ALIGN (storage_type),
storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type,
gnat_proc, gnat_pool, gnat_node);
storage = convert (storage_ptr_type, protect_multiple_eval (storage));
@ -2050,70 +2169,10 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
size = ssize_int (-1);
/* If this is in the default storage pool and the type alignment is larger
than what the default allocator supports, make an "aligning" record type
with room to store a pointer before the field, allocate an object of that
type, store the system's allocator return value just in front of the
field and return the field's address. */
if (No (gnat_proc) && TYPE_ALIGN (type) > default_allocator_alignment)
{
/* Construct the aligning type with enough room for a pointer ahead
of the field, then allocate. */
tree record_type
= make_aligning_type (type, TYPE_ALIGN (type), size,
default_allocator_alignment,
POINTER_SIZE / BITS_PER_UNIT);
tree record, record_addr;
record_addr
= build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type),
default_allocator_alignment, Empty, Empty,
gnat_node);
record_addr
= convert (build_pointer_type (record_type),
save_expr (record_addr));
record = build_unary_op (INDIRECT_REF, NULL_TREE, record_addr);
/* Our RESULT (the Ada allocator's value) is the super-aligned address
of the internal record field ... */
result
= build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref
(record, NULL_TREE, TYPE_FIELDS (record_type), 0));
result = convert (result_type, result);
/* ... with the system allocator's return value stored just in
front. */
{
tree ptr_addr
= build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
convert (ptr_void_type_node, result),
size_int (-POINTER_SIZE/BITS_PER_UNIT));
tree ptr_ref
= convert (build_pointer_type (ptr_void_type_node), ptr_addr);
result
= build2 (COMPOUND_EXPR, TREE_TYPE (result),
build_binary_op (MODIFY_EXPR, NULL_TREE,
build_unary_op (INDIRECT_REF, NULL_TREE,
ptr_ref),
convert (ptr_void_type_node,
record_addr)),
result);
}
}
else
result = convert (result_type,
build_call_alloc_dealloc (NULL_TREE, size,
TYPE_ALIGN (type),
gnat_proc,
gnat_pool,
gnat_node));
result = convert (result_type,
build_call_alloc_dealloc (NULL_TREE, size, type,
gnat_proc, gnat_pool,
gnat_node));
/* If we have an initial value, put the new address into a SAVE_EXPR, assign
the value, and return the address. Do this with a COMPOUND_EXPR. */

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2009-06-09 Olivier Hainque <hainque@adacore.com>
* gnat.dg/align_max.adb: New test.
2009-06-08 Jason Merrill <jason@redhat.com>
* g++.dg/cpp0x/auto15.C: New.

137
gcc/testsuite/gnat.dg/align_max.adb Normal file
View File

@ -0,0 +1,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;