https://gcc.gnu.org/g:6eb4909a31bef2a05a8666b7d9cdd25824e1a37e
commit r16-3981-g6eb4909a31bef2a05a8666b7d9cdd25824e1a37e
Author: Marc Poulhiès <poulh...@adacore.com>
Date: Tue Jul 15 11:44:56 2025 +0200
ada: Initial support for Extended Access types
This change introduces the support for the new GNAT specific
Extended_Access aspect for access to unconstrained array type :
type Ext_Access is access all Some_Array_Type with Extended_Access;
This new kind of access type does not use the existing "fat" layout with
a record of two pointers: one to the actual data, one to a record with the
bounds of the array. Instead, it removes the second indirection and extends
the record to contain the pointer to the actual data followed by the
bounds.
This mainly allows the following features:
- have access to slice of array
- easier interface when allocation is done in a foreign language
gcc/ada/ChangeLog:
* gcc-interface/ada-tree.h (TYPE_EXTENDED_POINTER_P): New.
(TYPE_IS_EXTENDED_POINTER_P): New.
(TYPE_EXTENDED_UNCONSTRAINED_ARRAY): New.
(SET_TYPE_EXTENDED_UNCONSTRAINED_ARRAY): New.
(TYPE_DUMMY_EXT_POINTER_TO): New.
(SET_TYPE_DUMMY_EXT_POINTER_TO): New.
* gcc-interface/decl.cc (get_extended_unconstrained_array): New.
(gnat_to_gnu_entity): Handle extended access type.
(get_unpadded_extended_type): New.
(gnat_to_gnu_component_type): Handle extended access type.
(build_template_type): New.
(gnat_to_gnu_field): Handle extended access type.
(validate_size): Likewise.
(set_rm_size): Likewise.
(copy_and_substitute_in_layout): Likewise.
(rm_size): Likewise.
* gcc-interface/gigi.h (get_unpadded_extended_type): New.
(build_template_type): New.
(build_dummy_unc_pointer_types_ext): New.
(finish_extended_pointer_type): New.
(build_unc_object_type_from_ptr): Rename first parameter.
* gcc-interface/misc.cc (gnat_print_type): Handle extended access
type.
* gcc-interface/trans.cc (Identifier_to_gnu): Likewise.
(Attribute_to_gnu): Likewise.
(gnat_to_gnu): Likewise.
* gcc-interface/utils.cc (convert_to_fat_pointer): Assert if
converting an
extended pointer.
(build_dummy_unc_pointer_types_ext): New.
(finish_extended_pointer_type): New.
(finish_record_type): Handle extended access type.
(build_unc_object_type_from_ptr): Likewise.
(convert_to_extended_pointer): New.
(convert): Handle extended access type.
(gnat_pushdecl): Likewise.
(maybe_pad_type): Likewise.
* gcc-interface/utils2.cc (build_unary_op): Likewise.
(build_binary_op): Likewise.
(build_allocator): Likewise.
(gnat_save_expr): Likewise.
(gnat_protect_expr): Likewise.
(gnat_stabilize_reference_1): Likewise.
Diff:
---
gcc/ada/gcc-interface/ada-tree.h | 27 ++
gcc/ada/gcc-interface/decl.cc | 520 ++++++++++++++++++++++++++++-----------
gcc/ada/gcc-interface/gigi.h | 38 ++-
gcc/ada/gcc-interface/misc.cc | 4 +-
gcc/ada/gcc-interface/trans.cc | 14 +-
gcc/ada/gcc-interface/utils.cc | 245 +++++++++++++++---
gcc/ada/gcc-interface/utils2.cc | 27 +-
7 files changed, 691 insertions(+), 184 deletions(-)
diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index 8f930dd8541b..3e41667d19e4 100644
--- a/gcc/ada/gcc-interface/ada-tree.h
+++ b/gcc/ada/gcc-interface/ada-tree.h
@@ -73,6 +73,14 @@ do { \
#define TYPE_IS_FAT_POINTER_P(NODE) \
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_FAT_POINTER_P (NODE))
+/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is a
+ record being used as an extended access (only true for RECORD_TYPE). */
+#define TYPE_EXTENDED_POINTER_P(NODE) \
+ TYPE_LANG_FLAG_7 (RECORD_OR_UNION_CHECK (NODE))
+
+#define TYPE_IS_EXTENDED_POINTER_P(NODE) \
+ (TREE_CODE (NODE) == RECORD_TYPE && TYPE_EXTENDED_POINTER_P (NODE))
+
/* For integral types and array types, nonzero if this is an implementation
type for a bit-packed array type. Such types should not be extended to a
larger size or validated against a specified size. */
@@ -384,6 +392,25 @@ do { \
#define SET_TYPE_SCALE_FACTOR(NODE, X) \
SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X)
+/* For an UNCONSTRAINED_ARRAY_TYPE, this is the twin UNCONSTRAINED_ARRAY_TYPE
+ built for extended access types. */
+#define TYPE_EXTENDED_UNCONSTRAINED_ARRAY(NODE) \
+ GET_TYPE_LANG_SPECIFIC (TREE_CHECK2 ((NODE), UNCONSTRAINED_ARRAY_TYPE, \
+ ENUMERAL_TYPE))
+#define SET_TYPE_EXTENDED_UNCONSTRAINED_ARRAY(NODE, X) \
+ SET_TYPE_LANG_SPECIFIC (TREE_CHECK2 ((NODE), UNCONSTRAINED_ARRAY_TYPE, \
+ ENUMERAL_TYPE), X)
+
+/* When the compiler only has a dummy type for an unconstrained array type, we
+ don't build a duplicate dummy only to store the record type for the extended
+ access. Instead, we store it in the original dummy type, using the same
+ lang_type field that will hold the tree for the duplicated array type built
+ later. */
+#define TYPE_DUMMY_EXT_POINTER_TO(NODE) \
+ GET_TYPE_LANG_SPECIFIC (TREE_CHECK ((NODE), ENUMERAL_TYPE))
+#define SET_TYPE_DUMMY_EXT_POINTER_TO(NODE, X) \
+ SET_TYPE_LANG_SPECIFIC (TREE_CHECK ((NODE), ENUMERAL_TYPE), X)
+
/* For types with TYPE_CAN_HAVE_DEBUG_TYPE_P, this is the type to use in
debugging information. */
#define TYPE_DEBUG_TYPE(NODE) \
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 00ccac3978e6..8dbc72e3d5ff 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -201,6 +201,7 @@ static tree gnat_to_gnu_component_type (Entity_Id, bool,
bool);
static tree gnat_to_gnu_subprog_type (Entity_Id, bool, bool, tree *);
static int adjust_packed (tree, tree, int);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
+static tree get_extended_unconstrained_array (Entity_Id, tree);
static enum inline_status_t inline_status_for_subprog (Entity_Id);
static Entity_Id Gigi_Cloned_Subtype (Entity_Id);
static tree gnu_ext_name_for_subprog (Entity_Id, tree);
@@ -279,6 +280,13 @@ is_artificial (Entity_Id gnat_entity)
initial value (in GCC tree form). This is optional for a variable. For
a renamed entity, GNU_EXPR gives the object being renamed.
+ If GNAT_ENTITY is an array type and GNU_EXPR is NULL_TREE, a GCC tree for a
+ regular fat pointer will be generated. However, if GNU_EXPR is not
+ NULL_TREE, it's an existing GCC tree for the fat pointer, and a GCC tree for
+ the extended pointer will be created instead. The caller must clear the
+ association between GNAT_ENTITY and GNU_EXPR before calling
+ gnat_to_gnu_entity with a non-NULL GNU_EXPR and restore it after the call.
+
DEFINITION is true if this call is intended for a definition. This is used
for separate compilation where it is necessary to know whether an external
declaration or a definition must be created if the GCC equivalent was not
@@ -441,7 +449,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
must be specified unless it was specified by the programmer. Exceptions
are for access-to-protected-subprogram types and all access subtypes, as
another GNAT type is used to lay out the GCC type for them, as well as
- access-to-subprogram types if front-end unnesting is enabled. */
+ access-to-subprogram types if front-end unnesting is enabled, and also
+ extended access types. */
gcc_assert (!is_type
|| Known_Esize (gnat_entity)
|| Has_Size_Clause (gnat_entity)
@@ -454,6 +463,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
|| kind == E_Anonymous_Access_Subprogram_Type)
&& Unnest_Subprogram_Mode)
|| kind == E_Access_Subtype
+ || Is_Extended_Access_Type (gnat_entity)
|| type_annotate_only)));
/* The RM size must be specified for all discrete and fixed-point types. */
@@ -1254,7 +1264,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
initialize it to NULL, unless the object is declared imported as
per RM B.1(24). */
if (definition
- && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
+ && (POINTER_TYPE_P (gnu_type)
+ || TYPE_IS_FAT_POINTER_P (gnu_type)
+ || TYPE_IS_EXTENDED_POINTER_P (gnu_type))
&& !gnu_expr
&& !Is_Imported (gnat_entity))
gnu_expr = null_pointer_node;
@@ -2165,21 +2177,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
have are pointers to that type. In addition to the type node itself,
4 other types associated with it are built in the process:
- 1. the array type (suffix XUA) containing the actual data,
+ 1. the array type (suffix XUA for fat pointer, XUAEA for extended
+ access) containing the actual data,
- 2. the template type (suffix XUB) containing the bounds,
+ 2. the template type (suffix XUB for fat pointer, XUBEA for extended
+ access) containing the bounds,
3. the fat pointer type (suffix XUP) representing a pointer or a
reference to the unconstrained array type:
XUP = struct { XUA *, XUB * }
- 4. the object record type (suffix XUT) containing bounds and data:
- XUT = struct { XUB, XUA }
+ or the extended access type (suffix XUPEA) representing a pointer
+ or a reference to the unconstrained array type:
+ XUPEA = struct { XUAEA *, XUBEA }
+
+ 4. the object record type (suffix XUT for fat pointer, XUTEA for
+ extended access) containing bounds and data:
+ XUT[EA] = struct { XUB[EA], XUA[EA] }
The bounds of the array type XUA (de)reference the XUB * field of a
PLACEHOLDER_EXPR for the fat pointer type XUP, so the array type XUA
is to be interpreted in the context of the fat pointer type XUB for
- debug info purposes. */
+ debug info purposes. Likewise for the extended access case. */
case E_Array_Type:
{
@@ -2187,14 +2206,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity);
const bool convention_fortran_p
= (Convention (gnat_entity) == Convention_Fortran);
+ const bool extended_access_p = gnu_expr != NULL_TREE;
const int ndim = Number_Dimensions (gnat_entity);
tree gnu_fat_type, gnu_template_type, gnu_ptr_template;
- tree gnu_template_reference, gnu_template_fields;
+ tree gnu_template_reference;
tree *gnu_index_types = XALLOCAVEC (tree, ndim);
- tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
tree gnu_max_size = size_one_node;
tree comp_type, fld, tem, obj;
- Entity_Id gnat_index;
alias_set_type ptr_set = -1;
int index;
@@ -2214,7 +2232,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
better debugging information in DWARF by leveraging the support for
incomplete declarations of "tagged" types in the DWARF back-end. */
gnu_type = get_dummy_type (gnat_entity);
- if (gnu_type && TYPE_POINTER_TO (gnu_type))
+ if (gnu_type && TYPE_POINTER_TO (gnu_type) && !extended_access_p)
{
gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
TYPE_NAME (gnu_fat_type) = NULL_TREE;
@@ -2229,10 +2247,42 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
DECL_CHAIN (TYPE_FIELDS (TYPE_POINTER_TO (gnu_type)))
= copy_node (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)));
}
+
+ /* We complete an existing dummy for extended access, but we haven't
+ created a specific tree yet for the array type. The extended access
+ type is stored directly in the original unconstrained array type,
+ where we will store the new array type later. */
+ else if (gnu_type
+ && TYPE_DUMMY_EXT_POINTER_TO (gnu_type)
+ && extended_access_p)
+ {
+ gnu_ptr_template = NULL_TREE;
+ tree gnu_ext_acc_type = TYPE_DUMMY_EXT_POINTER_TO (gnu_type);
+ gnu_fat_type = TYPE_MAIN_VARIANT (gnu_ext_acc_type);
+ TYPE_NAME (gnu_fat_type) = NULL_TREE;
+
+ /* The dummy types has a XUBEA that was only used to get the size of
+ the extended pointer. We now drop this type and use the XUB type
+ from the regular fat pointer instead. */
+ gnu_template_type
+ = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (TREE_TYPE
(gnu_expr)))));
+
+ DECL_CHAIN (TYPE_FIELDS (gnu_fat_type))
+ = create_field_decl (get_identifier ("BOUNDS"),
+ gnu_template_type, gnu_fat_type,
+ NULL_TREE, NULL_TREE, 0, 1);
+ }
+
else
{
gnu_fat_type = make_node (RECORD_TYPE);
- gnu_template_type = make_node (RECORD_TYPE);
+
+ if (extended_access_p)
+ gnu_template_type
+ = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (TREE_TYPE
(gnu_expr)))));
+ else
+ gnu_template_type = make_node (RECORD_TYPE);
+
gnu_ptr_template = build_pointer_type (gnu_template_type);
}
@@ -2264,7 +2314,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
Var are also built later with the fields of the final type, the
aliasing machinery may consider that the accesses are distinct
if the FIELD_DECLs are distinct as objects. */
- if (COMPLETE_TYPE_P (gnu_fat_type))
+ if (COMPLETE_TYPE_P (gnu_fat_type) && !extended_access_p)
{
fld = TYPE_FIELDS (gnu_fat_type);
if (TYPE_ALIAS_SET_KNOWN_P (TYPE_CANONICAL (TREE_TYPE (fld))))
@@ -2275,6 +2325,39 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
for (tree t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
}
+
+ else if (COMPLETE_TYPE_P (gnu_fat_type) && extended_access_p)
+ {
+ fld = TYPE_FIELDS (gnu_fat_type);
+ if (TYPE_ALIAS_SET_KNOWN_P (TYPE_CANONICAL (TREE_TYPE (fld))))
+ ptr_set = TYPE_ALIAS_SET (TYPE_CANONICAL (TREE_TYPE (fld)));
+ TREE_TYPE (fld) = ptr_type_node;
+ /* For extended access, we leave the BOUNDS field alone. */
+ TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 0;
+ for (tree t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
+ SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
+ }
+
+ else if (extended_access_p)
+ {
+ /* We make the fields addressable for the sake of compatibility
+ with languages for which the regular fields are addressable. */
+ fld
+ = create_field_decl (get_identifier ("P_ARRAY"),
+ ptr_type_node, gnu_fat_type,
+ NULL_TREE, NULL_TREE, 0, 1);
+ /* At this step, gnu_template_type is an empty RECORD to be
+ be populated later. */
+ DECL_CHAIN (fld)
+ = create_field_decl (get_identifier ("BOUNDS"),
+ gnu_template_type, gnu_fat_type,
+ NULL_TREE, NULL_TREE, 0, 1);
+ /* Too early to finish the record, but set the fields so that
+ they are available through the type. */
+ TYPE_FIELDS (gnu_fat_type) = fld;
+ SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
+ }
+
else
{
/* We make the fields addressable for the sake of compatibility
@@ -2302,135 +2385,56 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
: gnat_entity;
tree xup_name
= gnat_encodings == DWARF_GNAT_ENCODINGS_ALL
- ? create_concat_name (gnat_name, "XUP")
+ ? create_concat_name (gnat_name,
+ extended_access_p ? "XUPEA" : "XUP")
: gnu_entity_name;
create_type_decl (xup_name, gnu_fat_type, true, debug_info_p,
gnat_entity, false);
/* Build a reference to the template from a PLACEHOLDER_EXPR that
- is the fat pointer. This will be used to access the individual
- fields once we build them. */
- tem = build3 (COMPONENT_REF, gnu_ptr_template,
- build0 (PLACEHOLDER_EXPR, gnu_fat_type),
- DECL_CHAIN (fld), NULL_TREE);
- gnu_template_reference
- = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
- TREE_READONLY (gnu_template_reference) = 1;
- TREE_THIS_NOTRAP (gnu_template_reference) = 1;
-
- /* Now create the GCC type for each index and add the fields for that
- index to the template. */
- for (index = (convention_fortran_p ? ndim - 1 : 0),
- gnat_index = First_Index (gnat_entity);
- IN_RANGE (index, 0, ndim - 1);
- index += (convention_fortran_p ? - 1 : 1),
- gnat_index = Next_Index (gnat_index))
+ is the extended/fat pointer. This will be used to access the
+ individual fields once we build them. */
+ if (extended_access_p)
{
- const Entity_Id gnat_index_type = Etype (gnat_index);
- const bool is_flb
- = Is_Fixed_Lower_Bound_Index_Subtype (gnat_index_type);
- tree gnu_index_type = get_unpadded_type (gnat_index_type);
- tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
- tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
- tree gnu_index_base_type = get_base_type (gnu_index_type);
- tree gnu_lb_field, gnu_hb_field;
- tree gnu_min, gnu_max, gnu_high;
- char field_name[16];
-
- /* Update the maximum size of the array in elements. */
- if (gnu_max_size)
- gnu_max_size
- = update_n_elem (gnu_max_size, gnu_orig_min, gnu_orig_max);
-
- /* Now build the self-referential bounds of the index type. */
- gnu_index_type = maybe_character_type (gnu_index_type);
- gnu_index_base_type = maybe_character_type (gnu_index_base_type);
-
- /* Make the FIELD_DECLs for the low and high bounds of this
- type and then make extractions of these fields from the
- template. */
- sprintf (field_name, "LB%d", index);
- gnu_lb_field = create_field_decl (get_identifier (field_name),
- gnu_index_type,
- gnu_template_type, NULL_TREE,
- NULL_TREE, 0, 0);
- /* Mark the field specifically for INSTANTIATE_LOAD_IN_EXPR. */
- DECL_DISCRIMINANT_NUMBER (gnu_lb_field) = integer_minus_one_node;
- Sloc_to_locus (Sloc (gnat_entity),
- &DECL_SOURCE_LOCATION (gnu_lb_field));
-
- field_name[0] = 'U';
- gnu_hb_field = create_field_decl (get_identifier (field_name),
- gnu_index_type,
- gnu_template_type, NULL_TREE,
- NULL_TREE, 0, 0);
- /* Mark the field specifically for INSTANTIATE_LOAD_IN_EXPR. */
- DECL_DISCRIMINANT_NUMBER (gnu_hb_field) = integer_minus_one_node;
- Sloc_to_locus (Sloc (gnat_entity),
- &DECL_SOURCE_LOCATION (gnu_hb_field));
-
- gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
-
- /* We can't use build_component_ref here since the template type
- isn't complete yet. */
- if (!is_flb)
- {
- gnu_orig_min = build3 (COMPONENT_REF, TREE_TYPE (gnu_lb_field),
- gnu_template_reference, gnu_lb_field,
- NULL_TREE);
- TREE_READONLY (gnu_orig_min) = 1;
- }
-
- gnu_orig_max = build3 (COMPONENT_REF, TREE_TYPE (gnu_hb_field),
- gnu_template_reference, gnu_hb_field,
- NULL_TREE);
- TREE_READONLY (gnu_orig_max) = 1;
-
- gnu_min = convert (sizetype, gnu_orig_min);
- gnu_max = convert (sizetype, gnu_orig_max);
+ /* Extended pointers reference the template directly through the
+ BOUNDS field, which is the second field. */
+ gnu_template_reference
+ = build3 (COMPONENT_REF, gnu_template_type,
+ build0 (PLACEHOLDER_EXPR, gnu_fat_type),
+ DECL_CHAIN (fld), NULL_TREE);
+ TREE_READONLY (gnu_template_reference) = 1;
+ }
+ else
+ {
+ /* Fat pointers reference the template indirectly through the
+ P_BOUNDS field, which is the second field. */
+ tem = build3 (COMPONENT_REF, gnu_ptr_template,
+ build0 (PLACEHOLDER_EXPR, gnu_fat_type),
+ DECL_CHAIN (fld), NULL_TREE);
+ gnu_template_reference
+ = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
+ TREE_READONLY (gnu_template_reference) = 1;
+ TREE_THIS_NOTRAP (gnu_template_reference) = 1;
+ }
- /* Compute the size of this dimension. See the E_Array_Subtype
- case below for the rationale. */
- if (is_flb
- && Nkind (gnat_index) == N_Subtype_Indication
- && flb_cannot_be_superflat (gnat_index))
- gnu_high = gnu_max;
+ if (!extended_access_p)
+ {
+ /* Build the template type. */
+ TYPE_NAME (gnu_template_type)
+ = create_concat_name (gnat_entity, "XUB");
+ }
- else
- gnu_high
- = build3 (COND_EXPR, sizetype,
- build2 (GE_EXPR, boolean_type_node,
- gnu_orig_max, gnu_orig_min),
- gnu_max,
- TREE_CODE (gnu_min) == INTEGER_CST
- ? int_const_binop (MINUS_EXPR, gnu_min, size_one_node)
- : size_binop (MINUS_EXPR, gnu_min, size_one_node));
-
- /* Make a range type with the new range in the Ada base type.
- Then make an index type with the size range in sizetype. */
- gnu_index_types[index]
- = create_index_type (gnu_min, gnu_high,
- create_range_type (gnu_index_base_type,
- gnu_orig_min,
- gnu_orig_max),
- gnat_entity);
+ build_template_type (gnat_entity, gnu_template_type,
+ gnu_template_reference, gnu_index_types,
+ gnu_max_size, debug_info_p);
- TYPE_NAME (gnu_index_types[index])
- = create_concat_name (gnat_entity, field_name);
- }
+ if (!extended_access_p)
+ TYPE_CONTEXT (gnu_template_type) = gnu_fat_type;
- /* Install all the fields into the template. */
- TYPE_NAME (gnu_template_type)
- = create_concat_name (gnat_entity, "XUB");
- TYPE_NAMELESS (gnu_template_type)
- = gnat_encodings != DWARF_GNAT_ENCODINGS_ALL;
- gnu_template_fields = NULL_TREE;
- for (index = 0; index < ndim; index++)
- gnu_template_fields
- = chainon (gnu_template_fields, gnu_temp_fields[index]);
- finish_record_type (gnu_template_type, gnu_template_fields, 0,
- debug_info_p);
- TYPE_CONTEXT (gnu_template_type) = gnu_fat_type;
+ /* Now that the template type has been created, the record type for
+ extended access can be finished. */
+ if (extended_access_p)
+ finish_extended_pointer_type (gnu_fat_type, fld);
/* If Component_Size is not already specified, annotate it with the
size of the component. */
@@ -2510,9 +2514,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
TYPE_ARRAY_MAX_SIZE (tem) = gnu_max_size;
/* See the above description for the rationale. */
+ tree xua_name
+ = create_concat_name (gnat_entity,
+ extended_access_p ? "XUAEA" : "XUA");
tree gnu_tmp_decl
- = create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
- true, debug_info_p, gnat_entity);
+ = create_type_decl (xua_name, tem, true, debug_info_p, gnat_entity);
TYPE_CONTEXT (tem) = gnu_fat_type;
TYPE_CONTEXT (TYPE_POINTER_TO (tem)) = gnu_fat_type;
@@ -2524,7 +2530,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
If the GNAT encodings are used, give it a name. */
tree xut_name
= (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
- ? create_concat_name (gnat_name, "XUT")
+ ? create_concat_name (gnat_name,
+ extended_access_p ? "XUTEA" : "XUT")
: gnu_entity_name;
obj = build_unc_object_type (gnu_template_type, tem, xut_name,
artificial_p, debug_info_p);
@@ -2542,7 +2549,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
/* If this is a packed type implemented specially, then process the
implementation type so it is elaborated in the proper scope. */
- if (Present (PAT))
+ if (Present (PAT) && !extended_access_p)
{
/* Save the XUA type as our equivalent temporarily for the call
to gnat_to_gnu_type on the OAT below. */
@@ -3951,7 +3958,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
}
/* Access-to-unconstrained-array types need a special treatment. */
- if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep))
+ if (Is_Array_Type (gnat_desig_rep)
+ && !Is_Constrained (gnat_desig_rep)
+ && !Is_Extended_Access_Type (gnat_entity))
{
/* If the processing above got something that has a pointer, then
we are done. This could have happened either because the type
@@ -3962,6 +3971,26 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
gnu_type = TYPE_POINTER_TO (gnu_desig_type);
}
+ else if (Is_Array_Type (gnat_desig_rep)
+ && !Is_Constrained (gnat_desig_rep)
+ && Is_Extended_Access_Type (gnat_entity))
+ {
+ if (TYPE_IS_DUMMY_P (gnu_desig_type))
+ gnu_type
+ = build_dummy_unc_pointer_types_ext (gnat_desig_rep,
+ gnu_desig_type);
+ else
+ {
+ tree gnu_extended_type
+ = get_extended_unconstrained_array (gnat_desig_rep,
+ gnu_desig_type);
+
+ /* We should not get a dummy type. */
+ gnu_type = TYPE_POINTER_TO (gnu_extended_type);
+ gcc_assert (gnu_type);
+ }
+ }
+
/* If we haven't done it yet, build the pointer type the usual way. */
else if (!gnu_type)
{
@@ -4560,7 +4589,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
if (gnu_size)
size = gnu_size;
else if (RECORD_OR_UNION_TYPE_P (gnu_type)
- && !TYPE_FAT_POINTER_P (gnu_type))
+ && !TYPE_FAT_POINTER_P (gnu_type)
+ && !TYPE_EXTENDED_POINTER_P (gnu_type))
size = rm_size (gnu_type);
else
size = TYPE_SIZE (gnu_type);
@@ -5137,6 +5167,22 @@ get_unpadded_type (Entity_Id gnat_entity)
return type;
}
+/* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
+ the extended version of the GCC type corresponding to that entity. */
+
+tree
+get_unpadded_extended_type (Entity_Id gnat_entity)
+{
+ tree type = gnat_to_gnu_type (gnat_entity);
+
+ tree extended_type = get_extended_unconstrained_array (gnat_entity, type);
+
+ if (TYPE_IS_PADDING_P (extended_type))
+ extended_type = TREE_TYPE (TYPE_FIELDS (extended_type));
+
+ return extended_type;
+}
+
/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
a C++ imported method or equivalent.
@@ -5244,6 +5290,43 @@ is_cplusplus_method (Entity_Id gnat_entity)
return false;
}
+/* Get the UNCONSTRAINED_ARRAY_TYPE tree used for extended access handling,
+ for the unconstrained array type GNAT_ENTITY.
+
+ GNU_TYPE is the UNCONSTRAINED_ARRAY_TYPE tree used for the regular
+ fat/thin pointers. */
+
+static tree
+get_extended_unconstrained_array (Entity_Id gnat_entity, tree gnu_type)
+{
+ gcc_assert (Is_Array_Type (gnat_entity)
+ && TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
+
+ tree gnu_extended_type = TYPE_EXTENDED_UNCONSTRAINED_ARRAY (gnu_type);
+
+ /* Building the extended type is achieved by translating the array type
+ a second time using a special processing. */
+ if (!gnu_extended_type)
+ {
+ /* To have gnat_to_gnu_entity trigger the special processing for extended
+ access types, we pass GNU_TYPE as second parameter, we backup the
+ existing association for GNAT_ENTITY and clear it before the call. */
+ tree gnu_decl = get_gnu_tree (gnat_entity);
+ save_gnu_tree (gnat_entity, NULL_TREE, false);
+
+ gnu_extended_type
+ = TREE_TYPE (gnat_to_gnu_entity (gnat_entity, gnu_type, false));
+ gcc_assert (gnu_extended_type);
+ SET_TYPE_EXTENDED_UNCONSTRAINED_ARRAY (gnu_type, gnu_extended_type);
+
+ /* And finally, we restore the original association for GNAT_ENTITY. */
+ save_gnu_tree (gnat_entity, NULL_TREE, false);
+ save_gnu_tree (gnat_entity, gnu_decl, false);
+ }
+
+ return gnu_extended_type;
+}
+
/* Return the inlining status of the GNAT subprogram SUBPROG. */
static enum inline_status_t
@@ -5466,6 +5549,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool
definition,
&& !Strict_Alignment (gnat_type)
&& RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
+ && !TYPE_EXTENDED_POINTER_P (gnu_type)
&& tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
{
tree gnu_packable_type = make_packable_type (gnu_type, false, max_align);
@@ -7157,6 +7241,155 @@ elaborate_entity (Entity_Id gnat_entity)
}
}
+/* Build the template type GNU_TEMPLATE_TYPE for the array type GNAT_ENTITY.
+ GNU_TEMPLATE_REFERENCE is an expression to access the template value from
+ the pointer type. If GNU_INDEX_TYPES is not null, it's an array where the
+ index types whose bounds are the values of the template are to be stored.
+ If GNU_MAX_SIZE is not NULL_TREE, it's a tree where the maximum size of
+ the array type is computed. DEBUG_INFO_P is true if debug info needs to
+ be output for this type. */
+
+void
+build_template_type (Entity_Id gnat_entity, tree gnu_template_type,
+ tree gnu_template_reference,
+ tree *gnu_index_types, tree &gnu_max_size,
+ bool debug_info_p)
+{
+ const bool convention_fortran_p
+ = (Convention (gnat_entity) == Convention_Fortran);
+ const int ndim = Number_Dimensions (gnat_entity);
+ tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
+ Entity_Id gnat_index;
+ int index;
+
+ tree template_fields = TYPE_FIELDS (gnu_template_type);
+ const bool template_exists_p = template_fields != NULL_TREE;
+
+ /* Now create the GCC type for each index and add the fields for that
+ index to the template. */
+ for (index = (convention_fortran_p ? ndim - 1 : 0),
+ gnat_index = First_Index (gnat_entity);
+ IN_RANGE (index, 0, ndim - 1);
+ index += (convention_fortran_p ? - 1 : 1),
+ gnat_index = Next_Index (gnat_index))
+ {
+ const Entity_Id gnat_index_type = Etype (gnat_index);
+ const bool is_flb = Is_Fixed_Lower_Bound_Index_Subtype (gnat_index_type);
+ tree gnu_index_type = get_unpadded_type (gnat_index_type);
+ tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
+ tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
+ tree gnu_index_base_type = get_base_type (gnu_index_type);
+ tree gnu_lb_field, gnu_hb_field;
+ tree gnu_min, gnu_max, gnu_high;
+ char field_name[16];
+
+ /* Update the maximum size of the array in elements. */
+ if (gnu_max_size)
+ gnu_max_size
+ = update_n_elem (gnu_max_size, gnu_orig_min, gnu_orig_max);
+
+ /* Now build the self-referential bounds of the index type. */
+ gnu_index_type = maybe_character_type (gnu_index_type);
+ gnu_index_base_type = maybe_character_type (gnu_index_base_type);
+
+ if (template_fields != NULL_TREE)
+ {
+ gnu_lb_field = template_fields;
+ template_fields = DECL_CHAIN (template_fields);
+ gnu_hb_field = template_fields;
+ template_fields = DECL_CHAIN (template_fields);
+ }
+ else
+ {
+ /* Make the FIELD_DECLs for the low and high bounds of this
+ type and then make extractions of these fields from the
+ template. */
+ sprintf (field_name, "LB%d", index);
+ gnu_lb_field = create_field_decl (get_identifier (field_name),
+ gnu_index_type,
+ gnu_template_type, NULL_TREE,
+ NULL_TREE, 0, 0);
+ /* Mark the field specifically for INSTANTIATE_LOAD_IN_EXPR. */
+ DECL_DISCRIMINANT_NUMBER (gnu_lb_field) = integer_minus_one_node;
+ Sloc_to_locus (Sloc (gnat_entity), &DECL_SOURCE_LOCATION
(gnu_lb_field));
+
+ field_name[0] = 'U';
+ gnu_hb_field = create_field_decl (get_identifier (field_name),
+ gnu_index_type,
+ gnu_template_type, NULL_TREE,
+ NULL_TREE, 0, 0);
+ /* Mark the field specifically for INSTANTIATE_LOAD_IN_EXPR. */
+ DECL_DISCRIMINANT_NUMBER (gnu_hb_field) = integer_minus_one_node;
+ Sloc_to_locus (Sloc (gnat_entity), &DECL_SOURCE_LOCATION
(gnu_hb_field));
+
+ gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
+ }
+
+ if (gnu_index_types)
+ {
+ /* We can't use build_component_ref here since the template type
+ isn't complete yet. */
+ if (!is_flb)
+ {
+ gnu_orig_min
+ = build3 (COMPONENT_REF, TREE_TYPE (gnu_lb_field),
+ gnu_template_reference, gnu_lb_field,
+ NULL_TREE);
+ TREE_READONLY (gnu_orig_min) = 1;
+ }
+
+ gnu_orig_max = build3 (COMPONENT_REF, TREE_TYPE (gnu_hb_field),
+ gnu_template_reference, gnu_hb_field,
+ NULL_TREE);
+ TREE_READONLY (gnu_orig_max) = 1;
+
+ gnu_min = convert (sizetype, gnu_orig_min);
+ gnu_max = convert (sizetype, gnu_orig_max);
+
+ /* Compute the size of this dimension. See the E_Array_Subtype
+ case of gnat_to_gnu_entity for the rationale. */
+ if (is_flb
+ && Nkind (gnat_index) == N_Subtype_Indication
+ && flb_cannot_be_superflat (gnat_index))
+ gnu_high = gnu_max;
+
+ else
+ gnu_high
+ = build3 (COND_EXPR, sizetype,
+ build2 (GE_EXPR, boolean_type_node,
+ gnu_orig_max, gnu_orig_min),
+ gnu_max,
+ TREE_CODE (gnu_min) == INTEGER_CST
+ ? int_const_binop (MINUS_EXPR, gnu_min, size_one_node)
+ : size_binop (MINUS_EXPR, gnu_min, size_one_node));
+
+ /* Make a range type with the new range in the Ada base type.
+ Then make an index type with the size range in sizetype. */
+ gnu_index_types[index]
+ = create_index_type (gnu_min, gnu_high,
+ create_range_type (gnu_index_base_type,
+ gnu_orig_min,
+ gnu_orig_max),
+ gnat_entity);
+
+ TYPE_NAME (gnu_index_types[index])
+ = create_concat_name (gnat_entity, field_name);
+ }
+ }
+
+ if (!template_exists_p)
+ {
+ TYPE_NAMELESS (gnu_template_type)
+ = gnat_encodings != DWARF_GNAT_ENCODINGS_ALL;
+
+ tree gnu_template_fields = NULL_TREE;
+ for (index = 0; index < ndim; index++)
+ gnu_template_fields
+ = chainon (gnu_template_fields, gnu_temp_fields[index]);
+ finish_record_type (gnu_template_type, gnu_template_fields, 0,
debug_info_p);
+ }
+}
+
/* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
NAME, ARGS and ERROR_POINT. */
@@ -7778,6 +8011,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree
gnu_record_type, int packed,
if (!needs_strict_alignment
&& RECORD_OR_UNION_TYPE_P (gnu_field_type)
&& !TYPE_FAT_POINTER_P (gnu_field_type)
+ && !TYPE_EXTENDED_POINTER_P (gnu_field_type)
&& tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))
&& (packed == 1
|| is_bitfield
@@ -7975,6 +8209,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree
gnu_record_type, int packed,
if (!needs_strict_alignment
&& RECORD_OR_UNION_TYPE_P (gnu_field_type)
&& !TYPE_FAT_POINTER_P (gnu_field_type)
+ && !TYPE_EXTENDED_POINTER_P (gnu_field_type)
&& TYPE_MODE (gnu_field_type) == BLKmode
&& is_bitfield)
gnu_field_type = make_packable_type (gnu_field_type, true, 1);
@@ -9701,7 +9936,9 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id
gnat_object,
/* If this is an access type or a fat pointer, the minimum size is that given
by the default pointer mode. */
- if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
+ if (TREE_CODE (gnu_type) == POINTER_TYPE
+ || TYPE_IS_FAT_POINTER_P (gnu_type)
+ || TYPE_IS_EXTENDED_POINTER_P (gnu_type))
old_size = bitsize_int (GET_MODE_BITSIZE (ptr_mode));
/* Issue an error either if the default size of the object isn't a constant
@@ -9817,7 +10054,8 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id
gnat_entity)
/* ...or the Ada size for record and union types. */
else if (RECORD_OR_UNION_TYPE_P (gnu_type)
- && !TYPE_FAT_POINTER_P (gnu_type))
+ && !TYPE_FAT_POINTER_P (gnu_type)
+ && !TYPE_EXTENDED_POINTER_P (gnu_type))
SET_TYPE_ADA_SIZE (gnu_type, size);
}
@@ -10621,6 +10859,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
gnu_size = DECL_SIZE (gnu_old_field);
if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
&& !TYPE_FAT_POINTER_P (gnu_field_type)
+ && !TYPE_EXTENDED_POINTER_P (gnu_field_type)
&& tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)))
gnu_field_type = make_packable_type (gnu_field_type, true, 0);
}
@@ -10993,6 +11232,7 @@ rm_size (tree gnu_type)
/* For record or union types, we store the size explicitly. */
if (RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
+ && !TYPE_EXTENDED_POINTER_P (gnu_type)
&& TYPE_ADA_SIZE (gnu_type))
return TYPE_ADA_SIZE (gnu_type);
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 2533bd49434d..442647c8aa71 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -49,6 +49,14 @@ extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity);
the GCC type corresponding to that entity. */
extern tree gnat_to_gnu_type (Entity_Id gnat_entity);
+/* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
+ the unpadded version of the GCC type corresponding to that entity. */
+extern tree get_unpadded_type (Entity_Id gnat_entity);
+
+/* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
+ the extended version of the GCC type corresponding to that entity. */
+extern tree get_unpadded_extended_type (Entity_Id gnat_entity);
+
/* Update the GCC tree previously built for the profiles involving GNU_TYPE,
a dummy type which appears in profiles. */
extern void update_profiles_with (tree gnu_type);
@@ -107,8 +115,17 @@ extern Entity_Id Gigi_Equivalent_Type (Entity_Id
gnat_entity);
be elaborated at the point of its definition, but do nothing else. */
extern void elaborate_entity (Entity_Id gnat_entity);
-/* Get the unpadded version of a GNAT type. */
-extern tree get_unpadded_type (Entity_Id gnat_entity);
+/* Build the template type GNU_TEMPLATE_TYPE for the array type GNAT_ENTITY.
+ GNU_TEMPLATE_REFERENCE is an expression to access the template value from
+ the pointer type. If GNU_INDEX_TYPES is not null, it's an array where the
+ index types whose bounds are the values of the template are to be stored.
+ If GNU_MAX_SIZE is not NULL_TREE, it's a tree where the maximum size of
+ the array type is computed. DEBUG_INFO_P is true if debug info needs to
+ be output for this type. */
+extern void build_template_type (Entity_Id gnat_entity, tree gnu_template_type,
+ tree gnu_template_reference,
+ tree *gnu_index_types, tree &gnu_max_size,
+ bool debug_info_p);
/* Create a record type that contains a SIZE bytes long field of TYPE with a
starting bit position so that it is aligned to ALIGN bits, and leaving at
@@ -578,6 +595,11 @@ extern tree get_dummy_type (Entity_Id gnat_type);
extern void build_dummy_unc_pointer_types (Entity_Id gnat_desig_type,
tree gnu_desig_type);
+/* Build dummy extended access types whose designated type is specified by
+ GNAT_DESIG_TYPE/GNU_DESIG_TYPE and attach them to the latter. */
+extern tree build_dummy_unc_pointer_types_ext (Entity_Id gnat_desig_type,
+ tree gnu_desig_type);
+
/* Record TYPE as a builtin type for Ada. NAME is the name of the type.
ARTIFICIAL_P is true if the type was generated by the compiler. */
extern void record_builtin_type (const char *name, tree type,
@@ -590,6 +612,10 @@ extern void finish_character_type (tree char_type);
finish constructing the record type as a fat pointer type. */
extern void finish_fat_pointer_type (tree record_type, tree field_list);
+/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
+ finish constructing the record type as an extended access type. */
+extern void finish_extended_pointer_type (tree record_type, tree field_list);
+
/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
finish constructing the record or union type. If REP_LEVEL is zero, this
record has no representation clause and so will be entirely laid out here.
@@ -761,11 +787,9 @@ extern tree build_unc_object_type (tree template_type,
tree object_type,
tree name, bool artificial_p,
bool debug_info_p);
-/* Same as build_unc_object_type, but taking a thin or fat pointer type
- instead of the template type. */
-extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type,
- tree object_type, tree name,
- bool debug_info_p);
+/* Same, taking a pointer type instead of a template type. */
+extern tree build_unc_object_type_from_ptr (tree ptr_type, tree object_type,
+ tree name, bool debug_info_p);
/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
the normal case this is just two adjustments, but we have more to do
diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc
index a79b87e3bdb2..e0890a2efc2e 100644
--- a/gcc/ada/gcc-interface/misc.cc
+++ b/gcc/ada/gcc-interface/misc.cc
@@ -531,7 +531,9 @@ gnat_print_type (FILE *file, tree node, int indent)
break;
case RECORD_TYPE:
- if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
+ if (TYPE_EXTENDED_POINTER_P (node)
+ || TYPE_FAT_POINTER_P (node)
+ || TYPE_CONTAINS_TEMPLATE_P (node))
print_node (file, "unconstrained array",
TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
else
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index ea083f79a084..cf1a290e95ff 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -1250,6 +1250,10 @@ Identifier_to_gnu (Node_Id gnat_node, tree
*gnu_result_type_p)
no order-of-elaboration issue here. */
if (Is_Subprogram (gnat_entity))
gnu_result_type = NULL_TREE;
+ else if (Nkind (Original_Node (gnat_node)) == N_Explicit_Dereference
+ && Is_Extended_Access_Type
+ (Etype (Prefix (Original_Node (gnat_node)))))
+ gnu_result_type = get_unpadded_extended_type (gnat_result_type);
else
gnu_result_type = get_unpadded_type (gnat_result_type);
@@ -2033,7 +2037,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree
*gnu_result_type_p,
tree gnu_ptr_type
= TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
- if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
+ if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
+ || TYPE_IS_EXTENDED_POINTER_P (gnu_ptr_type))
gnu_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
@@ -6974,7 +6979,12 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Explicit_Dereference:
/* Make sure the designated type is complete before dereferencing. */
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ if (Is_Extended_Access_Type (Etype (Prefix (gnat_node)))
+ && !Is_Constrained (Etype (gnat_node)))
+ gnu_result_type = get_unpadded_extended_type (Etype (gnat_node));
+ else
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
gnu_result = gnat_to_gnu (Prefix (gnat_node));
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index ccb0752a11f0..b311232691fb 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -392,7 +392,6 @@ static tree fold_bit_position (const_tree);
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
static tree float_type_for_precision (int, machine_mode);
-static tree convert_to_fat_pointer (tree, tree);
static unsigned int scale_by_factor_of (tree, unsigned int);
/* Linked list used as a queue to defer the initialization of the DECL_CONTEXT
@@ -616,6 +615,59 @@ build_dummy_unc_pointer_types (Entity_Id gnat_desig_type,
tree gnu_desig_type)
TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type;
}
+/* Build dummy extended access types whose designated type is specified by
+ GNAT_DESIG_TYPE/GNU_DESIG_TYPE and attach them to the latter. */
+
+tree
+build_dummy_unc_pointer_types_ext (Entity_Id gnat_desig_type, tree
gnu_desig_type)
+{
+ tree gnu_template_type, gnu_array_type, gnu_ptr_array;
+ tree gnu_ext_acc_type = make_node (RECORD_TYPE);
+ tree fields, dummy = NULL_TREE;
+
+ gnu_template_type = make_node (RECORD_TYPE);
+ TYPE_NAME (gnu_template_type) = create_concat_name (gnat_desig_type,
"XUBEA");
+ TYPE_DUMMY_P (gnu_template_type) = 1;
+
+ /* This will also set TYPE_POINTER_TO field for the template type, even if
+ we don't need it here. */
+ build_pointer_type (gnu_template_type);
+
+ /* The following call only builds the template record, but other dependent
+ types or other more complex expressions for bounds are NOT created.
+ This allows the size of an extended access to be computed, but it must be
+ completed later. */
+ build_template_type (gnat_desig_type, gnu_template_type, NULL_TREE, NULL,
+ dummy, false);
+
+ TYPE_CONTEXT (gnu_template_type) = gnu_ext_acc_type;
+
+ gnu_array_type = make_node (ENUMERAL_TYPE);
+ TYPE_NAME (gnu_array_type) = create_concat_name (gnat_desig_type, "XUAEA");
+ TYPE_DUMMY_P (gnu_array_type) = 1;
+ gnu_ptr_array = build_pointer_type (gnu_array_type);
+
+ /* Build a stub DECL to trigger the special processing for fat pointer types
+ in gnat_pushdecl. */
+ TYPE_NAME (gnu_ext_acc_type)
+ = create_type_stub_decl (create_concat_name (gnat_desig_type, "XUPEA"),
+ gnu_ext_acc_type);
+ fields = create_field_decl (get_identifier ("P_ARRAY"), gnu_ptr_array,
+ gnu_ext_acc_type, NULL_TREE, NULL_TREE, 0, 1);
+ DECL_CHAIN (fields)
+ = create_field_decl (get_identifier ("BOUNDS"), gnu_template_type,
+ gnu_ext_acc_type, NULL_TREE, NULL_TREE, 0, 1);
+ finish_extended_pointer_type (gnu_ext_acc_type, fields);
+ SET_TYPE_UNCONSTRAINED_ARRAY (gnu_ext_acc_type, gnu_desig_type);
+
+ /* Suppress debug info until after the type is completed. */
+ TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_ext_acc_type)) = 1;
+
+ SET_TYPE_DUMMY_EXT_POINTER_TO (gnu_desig_type, gnu_ext_acc_type);
+
+ return gnu_ext_acc_type;
+}
+
/* Return true if we are in the global binding level. */
bool
@@ -937,11 +989,13 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
}
/* Pointer types aren't named types in the C sense so we need to generate a
- typedef in DWARF for them. Also do that for fat pointer types because,
- even though they are named types in the C sense, they are still the XUP
- types created for the base array type at this point. */
-#define TYPE_IS_POINTER_P(NODE) \
- (TREE_CODE (NODE) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (NODE))
+ typedef in DWARF for them. Also do that for fat and extended pointer types
+ because, even though they are named types in the C sense, they are still
+ the XUP[EA] types created for the base array type at this point. */
+#define TYPE_IS_POINTER_P(NODE)
\
+ (TREE_CODE (NODE) == POINTER_TYPE
\
+ || TYPE_IS_FAT_POINTER_P (NODE)
\
+ || TYPE_IS_EXTENDED_POINTER_P (NODE))
/* For the declaration of a type, set its name either if it isn't already
set or if the previous type name was not derived from a source name.
@@ -973,8 +1027,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t));
else
DECL_ORIGINAL_TYPE (decl) = t;
- /* Remark the canonical fat pointer type as artificial. */
- if (TYPE_IS_FAT_POINTER_P (t))
+ /* Remark the canonical fat or extended pointer type as artificial.
*/
+ if (TYPE_IS_FAT_POINTER_P (t) || TYPE_IS_EXTENDED_POINTER_P (t))
TYPE_ARTIFICIAL (t) = 1;
t = NULL_TREE;
}
@@ -1725,6 +1779,7 @@ maybe_pad_type (tree type, tree size, unsigned int align,
if (align > 0
&& RECORD_OR_UNION_TYPE_P (type)
&& !TYPE_IS_FAT_POINTER_P (type)
+ && !TYPE_IS_EXTENDED_POINTER_P (type)
&& TYPE_MODE (type) == BLKmode
&& !TYPE_BY_REFERENCE_P (type)
&& TREE_CODE (orig_size) == INTEGER_CST
@@ -2119,6 +2174,25 @@ finish_fat_pointer_type (tree record_type, tree
field_list)
TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2;
}
+/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
+ finish constructing the record type as an extended access type. */
+
+void
+finish_extended_pointer_type (tree record_type, tree field_list)
+{
+ /* Show what it really is. */
+ TYPE_EXTENDED_POINTER_P (record_type) = 1;
+
+ /* Do not emit debug info for it since the types of its fields may still be
+ incomplete at this point. */
+ finish_record_type (record_type, field_list, 0, false);
+
+ /* Force type_contains_placeholder_p to return true on it. Although the
+ PLACEHOLDER_EXPRs are referenced only indirectly, this isn't a pointer
+ type but the representation of the unconstrained array. */
+ TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2;
+}
+
/* Clear DECL_BIT_FIELD flag and associated markers on FIELD, which is a field
of aggregate type TYPE. */
@@ -2219,6 +2293,7 @@ finish_record_type (tree record_type, tree field_list,
int rep_level,
if (RECORD_OR_UNION_TYPE_P (type)
&& !TYPE_FAT_POINTER_P (type)
+ && !TYPE_EXTENDED_POINTER_P (type)
&& !TYPE_CONTAINS_TEMPLATE_P (type)
&& TYPE_ADA_SIZE (type))
this_ada_size = TYPE_ADA_SIZE (type);
@@ -2355,6 +2430,7 @@ finish_record_type (tree record_type, tree field_list,
int rep_level,
{
/* Now set any of the values we've just computed that apply. */
if (!TYPE_FAT_POINTER_P (record_type)
+ && !TYPE_EXTENDED_POINTER_P (record_type)
&& !TYPE_CONTAINS_TEMPLATE_P (record_type))
SET_TYPE_ADA_SIZE (record_type, ada_size);
}
@@ -4483,20 +4559,23 @@ build_unc_object_type (tree template_type, tree
object_type, tree name,
return type;
}
-/* Same, taking a thin or fat pointer type instead of a template type. */
+/* Same, taking a pointer type instead of a template type. */
tree
-build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
- tree name, bool debug_info_p)
+build_unc_object_type_from_ptr (tree ptr_type, tree object_type, tree name,
+ bool debug_info_p)
{
tree template_type;
- gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
-
- template_type
- = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type)
- ? TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (thin_fat_ptr_type))))
- : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type))));
+ if (TYPE_IS_EXTENDED_POINTER_P (ptr_type))
+ template_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr_type)));
+ else if (TYPE_IS_FAT_POINTER_P (ptr_type))
+ template_type
+ = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr_type))));
+ else if (TYPE_IS_THIN_POINTER_P (ptr_type))
+ template_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (ptr_type)));
+ else
+ gcc_unreachable ();
return
build_unc_object_type (template_type, object_type, name, true,
@@ -4652,6 +4731,9 @@ convert_to_fat_pointer (tree type, tree expr)
vec<constructor_elt, va_gc> *v;
vec_alloc (v, 2);
+ /* We don't allow conversion from extended to fat pointers. */
+ gcc_assert (!TYPE_IS_EXTENDED_POINTER_P (etype));
+
/* If EXPR is null, make a fat pointer that contains a null pointer to the
array (compare_fat_pointers ensures that this is the full discriminant)
and a valid pointer to the bounds. This latter property is necessary
@@ -4743,6 +4825,101 @@ convert_to_fat_pointer (tree type, tree expr)
return gnat_build_constructor (type, v);
}
+/* Convert EXPR, a pointer to a constrained array, into a pointer to an
+ unconstrained one using an extended access. This involves making or
+ finding a template. */
+
+static tree
+convert_to_extended_pointer (tree type, tree expr)
+{
+ tree template_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
+ tree p_array_type = TREE_TYPE (TYPE_FIELDS (type));
+ tree etype = TREE_TYPE (expr);
+ tree template_val;
+ vec<constructor_elt, va_gc> *v;
+ vec_alloc (v, 2);
+
+ /* If EXPR is null, make a fat pointer that contains a null pointer to the
+ array (compare_fat_pointers ensures that this is the full discriminant)
+ and a valid pointer to the bounds. This latter property is necessary
+ since the compiler can hoist the load of the bounds done through it. */
+ if (integer_zerop (expr))
+ {
+ tree template_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
+ tree null_bounds, t;
+
+ null_bounds = build_constructor (template_type, NULL);
+ TREE_CONSTANT (null_bounds) = TREE_STATIC (null_bounds) = 1;
+
+ CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
+ fold_convert (p_array_type, null_pointer_node));
+ CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)) ,
null_bounds);
+ t = build_constructor (type, v);
+ /* Do not set TREE_CONSTANT so as to force T to static memory. */
+ TREE_CONSTANT (t) = 0;
+ TREE_STATIC (t) = 1;
+
+ return t;
+ }
+
+ /* If EXPR is a thin pointer, make template and data from the record. */
+ if (TYPE_IS_THIN_POINTER_P (etype))
+ {
+ tree field = TYPE_FIELDS (TREE_TYPE (etype));
+
+ expr = gnat_protect_expr (expr);
+
+ /* If we have a TYPE_UNCONSTRAINED_ARRAY attached to the RECORD_TYPE,
+ the thin pointer value has been shifted so we shift it back to get
+ the template address. */
+ if (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (etype)))
+ {
+ tree template_addr
+ = fold_convert (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))), expr);
+ template_val = build_unary_op (INDIRECT_REF, NULL_TREE,
template_addr);
+ }
+
+ /* Otherwise we explicitly take the address of the fields. */
+ else
+ {
+ expr = build_unary_op (INDIRECT_REF, NULL_TREE, expr);
+
+ template_val = build_component_ref (expr, field, true);
+
+ expr = build_unary_op (ADDR_EXPR, NULL_TREE,
+ build_component_ref (expr, DECL_CHAIN (field),
+ false));
+ }
+ }
+
+ else if (TYPE_IS_FAT_POINTER_P (etype))
+ template_val
+ = build_unary_op (INDIRECT_REF, NULL_TREE,
+ build_component_ref (expr,
+ DECL_CHAIN (TYPE_FIELDS (etype)),
+ false));
+
+ /* Otherwise, build the constructor for the template. */
+ else
+ template_val = build_template (template_type, TREE_TYPE (etype), expr);
+
+ /* The final result is a constructor for the extended pointer.
+
+ If EXPR is an argument of a foreign convention subprogram, the type it
+ points to is directly the component type. In this case, the expression
+ type may not match the corresponding FIELD_DECL type at this point, so we
+ call "convert" here to fix that up if necessary. This type consistency is
+ required, for instance because it ensures that possible later folding of
+ COMPONENT_REFs against this constructor always yields something of the
+ same type as the initial reference.
+
+ Note that the call to "build_template" above is still fine because it
+ will only refer to the provided TEMPLATE_TYPE in this case. */
+ CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), convert (p_array_type, expr));
+ CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), template_val);
+ return gnat_build_constructor (type, v);
+}
+
/* Create an expression whose value is that of EXPR,
converted to type TYPE. The TREE_TYPE of the value
is always TYPE. This function implements all reasonable
@@ -5122,6 +5299,8 @@ convert (tree type, tree expr)
/* Check for converting to a pointer to an unconstrained array. */
if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype))
return convert_to_fat_pointer (type, expr);
+ if (TYPE_IS_EXTENDED_POINTER_P (type) && !TYPE_IS_EXTENDED_POINTER_P (etype))
+ return convert_to_extended_pointer (type, expr);
/* If we are converting between two aggregate or vector types that are mere
variants, just make a VIEW_CONVERT_EXPR. Likewise when we are converting
@@ -5264,7 +5443,7 @@ convert (tree type, tree expr)
/* If converting fat pointer to normal or thin pointer, get the pointer
to the array and then convert it. */
- if (TYPE_IS_FAT_POINTER_P (etype))
+ if (TYPE_IS_FAT_POINTER_P (etype) || TYPE_IS_EXTENDED_POINTER_P (etype))
expr = build_component_ref (expr, TYPE_FIELDS (etype), false);
return fold (convert_to_pointer (type, expr));
@@ -5328,20 +5507,30 @@ convert (tree type, tree expr)
}
/* If EXPR is a constrained array, take its address, convert it to a
- fat pointer, and then dereference it. Likewise if EXPR is a
- record containing both a template and a constrained array.
- Note that a record representing a justified modular type
- always represents a packed constrained array. */
+ fat or extended pointer, and then dereference it. Likewise if
+ EXPR is a record containing both a template and a constrained
+ array. Note that a record representing a justified modular type
+ always represents a packed constrained array. */
if (ecode == ARRAY_TYPE
|| (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
|| (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
|| (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))
- return
- build_unary_op
- (INDIRECT_REF, NULL_TREE,
- convert_to_fat_pointer (TREE_TYPE (type),
- build_unary_op (ADDR_EXPR,
- NULL_TREE, expr)));
+ {
+ if (TYPE_IS_EXTENDED_POINTER_P (TREE_TYPE (type)))
+ return
+ build_unary_op
+ (INDIRECT_REF, NULL_TREE,
+ convert_to_extended_pointer (TREE_TYPE (type),
+ build_unary_op (ADDR_EXPR,
+ NULL_TREE, expr)));
+ else
+ return
+ build_unary_op
+ (INDIRECT_REF, NULL_TREE,
+ convert_to_fat_pointer (TREE_TYPE (type),
+ build_unary_op (ADDR_EXPR,
+ NULL_TREE, expr)));
+ }
/* Do something very similar for converting one unconstrained
array to another. */
diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
index b76054c1769b..8f2ad7b3b8ac 100644
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -1294,6 +1294,14 @@ build_binary_op (enum tree_code op_code, tree
result_type,
best_type = left_base_type;
}
+ else if (TYPE_IS_EXTENDED_POINTER_P (left_base_type)
+ && TYPE_IS_EXTENDED_POINTER_P (right_base_type))
+ {
+ gcc_assert (TYPE_MAIN_VARIANT (left_base_type)
+ == TYPE_MAIN_VARIANT (right_base_type));
+ best_type = left_base_type;
+ }
+
else if (POINTER_TYPE_P (left_base_type)
&& POINTER_TYPE_P (right_base_type))
{
@@ -1735,7 +1743,7 @@ build_unary_op (enum tree_code op_code, tree result_type,
tree operand)
/* If we want to refer to an unconstrained array, use the appropriate
expression. But this will never survive down to the back-end. */
- if (TYPE_IS_FAT_POINTER_P (type))
+ if (TYPE_IS_FAT_POINTER_P (type) || TYPE_IS_EXTENDED_POINTER_P (type))
{
result = build1 (UNCONSTRAINED_ARRAY_REF,
TYPE_UNCONSTRAINED_ARRAY (type), operand);
@@ -1754,7 +1762,9 @@ build_unary_op (enum tree_code op_code, tree result_type,
tree operand)
TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type));
}
- if (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)))
+ if (!TYPE_IS_FAT_POINTER_P (type)
+ && !TYPE_IS_EXTENDED_POINTER_P (type)
+ && TYPE_VOLATILE (TREE_TYPE (type)))
{
TREE_SIDE_EFFECTS (result) = 1;
if (INDIRECT_REF_P (result))
@@ -2607,7 +2617,8 @@ build_allocator (tree type, tree init, tree result_type,
Entity_Id gnat_proc,
/* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
sizes of the object and its template. Allocate the whole thing and
fill in the parts that are known. */
- else if (TYPE_IS_FAT_OR_THIN_POINTER_P (result_type))
+ else if (TYPE_IS_FAT_OR_THIN_POINTER_P (result_type)
+ || TYPE_IS_EXTENDED_POINTER_P (result_type))
{
tree storage_type
= build_unc_object_type_from_ptr (result_type, type,
@@ -3053,7 +3064,8 @@ gnat_save_expr (tree exp)
This may be more efficient, but will also allow us to more easily find
the match for the PLACEHOLDER_EXPR. */
if (code == COMPONENT_REF
- && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
+ && (TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0)))
+ || TYPE_IS_EXTENDED_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0)))))
return build3 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)),
TREE_OPERAND (exp, 1), NULL_TREE);
@@ -3122,7 +3134,8 @@ gnat_protect_expr (tree exp)
This may be more efficient, but will also allow us to more easily find
the match for the PLACEHOLDER_EXPR. */
if (code == COMPONENT_REF
- && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
+ && (TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0)))
+ || TYPE_IS_EXTENDED_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0)))))
return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)),
TREE_OPERAND (exp, 1), NULL_TREE);
@@ -3130,6 +3143,7 @@ gnat_protect_expr (tree exp)
for a CALL_EXPR as large objects are returned via invisible reference
in most ABIs so the temporary will directly be filled by the callee. */
if (TYPE_IS_FAT_POINTER_P (type)
+ || TYPE_IS_EXTENDED_POINTER_P (type)
|| !AGGREGATE_TYPE_P (type)
|| code == CALL_EXPR)
return save_expr (exp);
@@ -3166,7 +3180,8 @@ gnat_stabilize_reference_1 (tree e, void *data)
fat pointer. This may be more efficient, but will also allow
us to more easily find the match for the PLACEHOLDER_EXPR. */
if (code == COMPONENT_REF
- && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
+ && (TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))
+ || TYPE_IS_EXTENDED_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))))
result
= build3 (code, type,
gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), data),
