Skip to content

R
riscv-gcc-1
Commit 1eb58520 by Arnaud Charlet
Options

ada-tree.h (DECL_BY_DESCRIPTOR_P): Delete. 

2014-08-01  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/ada-tree.h (DECL_BY_DESCRIPTOR_P): Delete.
	(DECL_FUNCTION_STUB): Likewise.
	(SET_DECL_FUNCTION_STUB): Likewise.
	(DECL_PARM_ALT_TYPE): Likewise.
	(SET_DECL_PARM_ALT_TYPE): Likewise.
	(TYPE_VAX_FLOATING_POINT_P): Delete.
	(TYPE_DIGITS_VALUE): Likewise.
	(SET_TYPE_DIGITS_VALUE): Likewise.
	* gcc-interface/gigi.h (standard_datatypes): Remove ADT_malloc32_decl.
	(malloc32_decl): Delete.
	(build_vms_descriptor): Likewise.
	(build_vms_descriptor32): Likewise.
	(fill_vms_descriptor): Likewise.
	(convert_vms_descriptor): Likewise.
	(TARGET_ABI_OPEN_VMS): Likewise.
	(TARGET_MALLOC64): Likewise.
	* gcc-interface/decl.c (add_parallel_type_for_packed_array): New.
	(gnat_to_gnu_entity): Call it to add the original type as a parallel
	type to the implementation type of a packed array type.
	<E_Procedure>: Remove now obsolete kludge.
	<E_Exception>: Delete obsolete comment.
	<object>: Small tweak.
	<E_Subprogram_Type>: Remove support for stub subprograms, as well as
	for the descriptor passing mechanism.
	(gnat_to_gnu_param): Likewise.
	* gcc-interface/misc.c (gnat_init_gcc_fp): Remove special case.
	(gnat_print_type): Adjust.
	* gcc-interface/trans.c (gigi): Remove obsolete initializations.
	(vms_builtin_establish_handler_decl): Delete.
	(gnat_vms_condition_handler_decl): Likewise.
	(establish_gnat_vms_condition_handler): Likewise.
	(build_function_stub): Likewise.
	(Subprogram_Body_to_gnu): Do not call above functions.
	(Call_to_gnu): Remove support for the descriptor passing mechanism.
	* gcc-interface/utils.c (make_descriptor_field): Delete.
	(build_vms_descriptor32): Likewise.
	(build_vms_descriptor): Likewise.
	(fill_vms_descriptor): Likewise.
	(convert_vms_descriptor64): Likewise.
	(convert_vms_descriptor32): Likewise.
	(convert_vms_descriptor): Likewise.
	* gcc-interface/utils.c (unchecked_convert): Likewise.
	* gcc-interface/utils2.c (maybe_wrap_malloc): Remove obsolete stuff.

2014-08-01  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/trans.c (gigi): Use gnat_to_gnu_type for the exception
	type and get_unpadded_type for the longest FP type.
	(Attribute_to_gnu) <Machine>: Compare the precision of the types.
	(convert_with_check): Adjust formatting and remove FIXME.

2014-08-01  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Signed_Integer_Subtype>:
	Do not convert the RM bounds to the base type.
	(E_Floating_Point_Subtype): Likewise.
	(E_Array_Subtype): Convert the bounds to the base type.
	* gcc-interface/trans.c (get_type_length): New function.
	(Attribute_to_gnu) <Range_Length>: Call it.
	<Length>: Likewise.
	(Loop_Statement_to_gnu): Convert the bounds to the base type.
	(gnat_to_gnu) <N_In>: Likewise.
	* gcc-interface/utils.c (make_type_from_size): Do not convert the RM
	bounds to the base type.
	(create_range_type): Likewise.
	(convert): Convert the bounds to the base type for biased types.
	* gcc-interface/utils2.c (compare_arrays): Convert the bounds to the
	base type.

2014-08-01  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/trans.c (gnat_to_gnu) <N_Selected_Component>: Remove
	incorrect implicit type derivation.
	* gcc-interface/utils.c (max_size) <tcc_reference>: Convert the bounds
	to the base type.

From-SVN: r213462
parent ecda544d
Showing with 299 additions and 1503 deletions
gcc/ada/ChangeLog
2014-08-01 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/ada-tree.h (DECL_BY_DESCRIPTOR_P): Delete.
(DECL_FUNCTION_STUB): Likewise.
(SET_DECL_FUNCTION_STUB): Likewise.
(DECL_PARM_ALT_TYPE): Likewise.
(SET_DECL_PARM_ALT_TYPE): Likewise.
(TYPE_VAX_FLOATING_POINT_P): Delete.
(TYPE_DIGITS_VALUE): Likewise.
(SET_TYPE_DIGITS_VALUE): Likewise.
* gcc-interface/gigi.h (standard_datatypes): Remove ADT_malloc32_decl.
(malloc32_decl): Delete.
(build_vms_descriptor): Likewise.
(build_vms_descriptor32): Likewise.
(fill_vms_descriptor): Likewise.
(convert_vms_descriptor): Likewise.
(TARGET_ABI_OPEN_VMS): Likewise.
(TARGET_MALLOC64): Likewise.
* gcc-interface/decl.c (add_parallel_type_for_packed_array): New.
(gnat_to_gnu_entity): Call it to add the original type as a parallel
type to the implementation type of a packed array type.
<E_Procedure>: Remove now obsolete kludge.
<E_Exception>: Delete obsolete comment.
<object>: Small tweak.
<E_Subprogram_Type>: Remove support for stub subprograms, as well as
for the descriptor passing mechanism.
(gnat_to_gnu_param): Likewise.
* gcc-interface/misc.c (gnat_init_gcc_fp): Remove special case.
(gnat_print_type): Adjust.
* gcc-interface/trans.c (gigi): Remove obsolete initializations.
(vms_builtin_establish_handler_decl): Delete.
(gnat_vms_condition_handler_decl): Likewise.
(establish_gnat_vms_condition_handler): Likewise.
(build_function_stub): Likewise.
(Subprogram_Body_to_gnu): Do not call above functions.
(Call_to_gnu): Remove support for the descriptor passing mechanism.
* gcc-interface/utils.c (make_descriptor_field): Delete.
(build_vms_descriptor32): Likewise.
(build_vms_descriptor): Likewise.
(fill_vms_descriptor): Likewise.
(convert_vms_descriptor64): Likewise.
(convert_vms_descriptor32): Likewise.
(convert_vms_descriptor): Likewise.
* gcc-interface/utils.c (unchecked_convert): Likewise.
* gcc-interface/utils2.c (maybe_wrap_malloc): Remove obsolete stuff.
2014-08-01 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (gigi): Use gnat_to_gnu_type for the exception
type and get_unpadded_type for the longest FP type.
(Attribute_to_gnu) <Machine>: Compare the precision of the types.
(convert_with_check): Adjust formatting and remove FIXME.
2014-08-01 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Signed_Integer_Subtype>:
Do not convert the RM bounds to the base type.
(E_Floating_Point_Subtype): Likewise.
(E_Array_Subtype): Convert the bounds to the base type.
* gcc-interface/trans.c (get_type_length): New function.
(Attribute_to_gnu) <Range_Length>: Call it.
<Length>: Likewise.
(Loop_Statement_to_gnu): Convert the bounds to the base type.
(gnat_to_gnu) <N_In>: Likewise.
* gcc-interface/utils.c (make_type_from_size): Do not convert the RM
bounds to the base type.
(create_range_type): Likewise.
(convert): Convert the bounds to the base type for biased types.
* gcc-interface/utils2.c (compare_arrays): Convert the bounds to the
base type.
2014-08-01 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (gnat_to_gnu) <N_Selected_Component>: Remove
incorrect implicit type derivation.
* gcc-interface/utils.c (max_size) <tcc_reference>: Convert the bounds
to the base type.
2014-08-01 Hristian Kirtchev <kirtchev@adacore.com>
* sem_attr.adb (Analyze_Attribute): Preanalyze and resolve the
prefix of attribute Loop_Entry.
* sem_prag.adb (Analyze_Pragma): Verify the placement of pragma
Loop_Variant with respect to an enclosing loop (if any).
(Contains_Loop_Entry): Update the parameter profile and all
calls to this routine.
* sem_res.adb (Resolve_Call): Code reformatting. Do not ask
for the corresponding body before determining the nature of the
ultimate alias's declarative node.
2014-08-01 Robert Dewar <dewar@adacore.com>
* gnat1drv.adb, sem_ch4.adb: Minor reformatting.
2014-08-01 Robert Dewar <dewar@adacore.com>
* sem_eval.adb (Rewrite_In_Raise_CE): Don't try to reuse inner
constraint error node since it is a list member.
2014-08-01 Robert Dewar <dewar@adacore.com>
* sem_warn.adb: Minor reformatting.
2014-08-01 Eric Botcazou <ebotcazou@adacore.com>
* einfo.adb (Underlying_Type): Return the underlying full view
of a private type if present.
* freeze.adb (Freeze_Entity):
Build a single freeze node for partial, full and underlying full
views, if any.
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Private_Type>: Add a
missing guard before the access to the Underlying_Full_View.
* gcc-interface/trans.c (process_freeze_entity): Deal with underlying
full view if present.
* gcc-interface/utils.c (make_dummy_type): Avoid superfluous work.
2014-08-01 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Entry_Call): When an entry has
......
gcc/ada/gcc-interface/ada-tree.h
......@@ -120,11 +120,6 @@ do { \
|| TREE_CODE (NODE) == ENUMERAL_TYPE) \
&& TYPE_BY_REFERENCE_P (NODE))
/* For INTEGER_TYPE, nonzero if this really represents a VAX
floating-point type. */
#define TYPE_VAX_FLOATING_POINT_P(NODE) \
TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE))
/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is the
type for an object whose type includes its template in addition to
its value (only true for RECORD_TYPE). */
......@@ -257,7 +252,11 @@ do { \
bound but they must nevertheless be valid in the GCC type system, otherwise
the optimizer can pretend that they simply don't exist. Therefore they
must be within the range of values allowed by the lower bound in the GCC
sense, hence the GCC lower bound be set to that of the base type. */
sense, hence the GCC lower bound be set to that of the base type.
This lower bound is translated directly without the adjustments that may
be required for type compatibility, so it will generally be necessary to
convert it to the base type of the numerical type before using it. */
#define TYPE_RM_MIN_VALUE(NODE) TYPE_RM_VALUE ((NODE), 1)
#define SET_TYPE_RM_MIN_VALUE(NODE, X) SET_TYPE_RM_VALUE ((NODE), 1, (X))
......@@ -269,7 +268,11 @@ do { \
bound but they must nevertheless be valid in the GCC type system, otherwise
the optimizer can pretend that they simply don't exist. Therefore they
must be within the range of values allowed by the upper bound in the GCC
sense, hence the GCC upper bound be set to that of the base type. */
sense, hence the GCC upper bound be set to that of the base type.
This upper bound is translated directly without the adjustments that may
be required for type compatibility, so it will generally be necessary to
convert it to the base type of the numerical type before using it. */
#define TYPE_RM_MAX_VALUE(NODE) TYPE_RM_VALUE ((NODE), 2)
#define SET_TYPE_RM_MAX_VALUE(NODE, X) SET_TYPE_RM_VALUE ((NODE), 2, (X))
......@@ -294,15 +297,18 @@ do { \
#define SET_TYPE_MODULUS(NODE, X) \
SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X)
/* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, this is the
Digits_Value. */
#define TYPE_DIGITS_VALUE(NODE) \
GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
#define SET_TYPE_DIGITS_VALUE(NODE, X) \
SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X)
/* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, this is
the type corresponding to the Ada index type. */
the type corresponding to the Ada index type. It is necessary to keep
these 2 views for every array type because the TYPE_DOMAIN is subject
to strong constraints in GENERIC: it must be a subtype of SIZETYPE and
may not be superflat, i.e. the upper bound must always be larger or
equal to the lower bound minus 1 (i.e. the canonical length formula
must always yield a non-negative number), which means that at least
one of the bounds may need to be a conditional expression. There are
no such constraints on the TYPE_INDEX_TYPE because gigi is prepared to
deal with the superflat case; moreover the TYPE_INDEX_TYPE is used as
the index type for the debug info and, therefore, needs to be as close
as possible to the source index type. */
#define TYPE_INDEX_TYPE(NODE) \
GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
#define SET_TYPE_INDEX_TYPE(NODE, X) \
......@@ -388,9 +394,6 @@ do { \
is readonly. */
#define DECL_POINTS_TO_READONLY_P(NODE) DECL_LANG_FLAG_4 (NODE)
/* Nonzero in a PARM_DECL if we are to pass by descriptor. */
#define DECL_BY_DESCRIPTOR_P(NODE) DECL_LANG_FLAG_5 (PARM_DECL_CHECK (NODE))
/* Nonzero in a VAR_DECL if it is a pointer renaming a global object. */
#define DECL_RENAMING_GLOBAL_P(NODE) DECL_LANG_FLAG_5 (VAR_DECL_CHECK (NODE))
......@@ -448,19 +451,6 @@ do { \
#define SET_DECL_PARALLEL_TYPE(NODE, X) \
SET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE), X)
/* In a FUNCTION_DECL, points to the stub associated with the function
if any, otherwise 0. */
#define DECL_FUNCTION_STUB(NODE) \
GET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE))
#define SET_DECL_FUNCTION_STUB(NODE, X) \
SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X)
/* In a PARM_DECL, points to the alternate TREE_TYPE. */
#define DECL_PARM_ALT_TYPE(NODE) \
GET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE))
#define SET_DECL_PARM_ALT_TYPE(NODE, X) \
SET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE), X)
/* Flags added to ref nodes. */
......
gcc/ada/gcc-interface/decl.c
......@@ -172,6 +172,7 @@ static tree get_rep_part (tree);
static tree create_variant_part_from (tree, vec<variant_desc> , tree,
tree, vec<subst_pair> );
static void copy_and_substitute_in_size (tree, tree, vec<subst_pair> );
static void add_parallel_type_for_packed_array (tree, Entity_Id);
/* The relevant constituents of a subprogram binding to a GCC builtin. Used
to pass around calls performing profile compatibility checks. */
......@@ -488,15 +489,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
goto object;
case E_Exception:
/* We used to special case VMS exceptions here to directly map them to
their associated condition code. Since this code had to be masked
dynamically to strip off the severity bits, this caused trouble in
the GCC/ZCX case because the "type" pointers we store in the tables
have to be static. We now don't special case here anymore, and let
the regular processing take place, which leaves us with a regular
exception data object for VMS exceptions too. The condition code
mapping is taken care of by the front end and the bitmasking by the
run-time library. */
goto object;
case E_Component:
......@@ -1431,14 +1423,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
gnu_expr = convert (gnu_type, gnu_expr);
/* If this name is external or there was a name specified, use it,
Don't use the Interface_Name if there is an address clause
(see CD30005). */
/* If this name is external or a name was specified, use it, but don't
use the Interface_Name with an address clause (see cd30005). */
if ((Present (Interface_Name (gnat_entity))
&& No (Address_Clause (gnat_entity)))
|| (Is_Public (gnat_entity)
&& (!Is_Imported (gnat_entity)
|| Is_Exported (gnat_entity))))
&& (!Is_Imported (gnat_entity) || Is_Exported (gnat_entity))))
gnu_ext_name = create_concat_name (gnat_entity, NULL);
/* If this is an aggregate constant initialized to a constant, force it
......@@ -1754,20 +1744,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
SET_TYPE_RM_MIN_VALUE
(gnu_type,
convert (TREE_TYPE (gnu_type),
elaborate_expression (Type_Low_Bound (gnat_entity),
(gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
gnat_entity, get_identifier ("L"),
definition, true,
Needs_Debug_Info (gnat_entity))));
Needs_Debug_Info (gnat_entity)));
SET_TYPE_RM_MAX_VALUE
(gnu_type,
convert (TREE_TYPE (gnu_type),
elaborate_expression (Type_High_Bound (gnat_entity),
(gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
gnat_entity, get_identifier ("U"),
definition, true,
Needs_Debug_Info (gnat_entity))));
Needs_Debug_Info (gnat_entity)));
TYPE_BIASED_REPRESENTATION_P (gnu_type)
= Has_Biased_Representation (gnat_entity);
......@@ -1790,12 +1776,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
= create_type_stub_decl (gnu_entity_name, gnu_type);
/* For a packed array, make the original array type a parallel type. */
if (debug_info_p
&& Is_Packed_Array_Impl_Type (gnat_entity)
&& present_gnu_tree (Original_Array_Type (gnat_entity)))
add_parallel_type (gnu_type,
gnat_to_gnu_type
(Original_Array_Type (gnat_entity)));
if (debug_info_p && Is_Packed_Array_Impl_Type (gnat_entity))
add_parallel_type_for_packed_array (gnu_type, gnat_entity);
discrete_type:
......@@ -1867,10 +1849,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (debug_info_p)
{
/* Make the original array type a parallel type. */
if (present_gnu_tree (Original_Array_Type (gnat_entity)))
add_parallel_type (gnu_type,
gnat_to_gnu_type
(Original_Array_Type (gnat_entity)));
add_parallel_type_for_packed_array (gnu_type, gnat_entity);
rest_of_record_type_compilation (gnu_type);
}
......@@ -1947,20 +1926,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
layout_type (gnu_type);
SET_TYPE_RM_MIN_VALUE
(gnu_type,
convert (TREE_TYPE (gnu_type),
elaborate_expression (Type_Low_Bound (gnat_entity),
(gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
gnat_entity, get_identifier ("L"),
definition, true,
Needs_Debug_Info (gnat_entity))));
Needs_Debug_Info (gnat_entity)));
SET_TYPE_RM_MAX_VALUE
(gnu_type,
convert (TREE_TYPE (gnu_type),
elaborate_expression (Type_High_Bound (gnat_entity),
(gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
gnat_entity, get_identifier ("U"),
definition, true,
Needs_Debug_Info (gnat_entity))));
Needs_Debug_Info (gnat_entity)));
/* Inherit our alias set from what we're a subtype of, as for
integer subtypes. */
......@@ -2335,14 +2310,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnat_base_index = Next_Index (gnat_base_index))
{
tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
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_orig_min
= convert (gnu_index_base_type,
TYPE_MIN_VALUE (gnu_index_type));
tree gnu_orig_max
= convert (gnu_index_base_type,
TYPE_MAX_VALUE (gnu_index_type));
tree gnu_min = convert (sizetype, gnu_orig_min);
tree gnu_max = convert (sizetype, gnu_orig_max);
tree gnu_base_index_type
= get_unpadded_type (Etype (gnat_base_index));
tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
tree gnu_base_index_base_type
= get_base_type (gnu_base_index_type);
tree gnu_base_orig_min
= convert (gnu_base_index_base_type,
TYPE_MIN_VALUE (gnu_base_index_type));
tree gnu_base_orig_max
= convert (gnu_base_index_base_type,
TYPE_MAX_VALUE (gnu_base_index_type));
tree gnu_high;
/* See if the base array type is already flat. If it is, we
......@@ -2655,11 +2641,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
isn't artificial to make sure it is kept in the debug info. */
if (debug_info_p)
{
if (Is_Packed_Array_Impl_Type (gnat_entity)
&& present_gnu_tree (Original_Array_Type (gnat_entity)))
add_parallel_type (gnu_type,
gnat_to_gnu_type
(Original_Array_Type (gnat_entity)));
if (Is_Packed_Array_Impl_Type (gnat_entity))
add_parallel_type_for_packed_array (gnu_type, gnat_entity);
else
{
tree gnu_base_decl
......@@ -4102,8 +4085,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
PARM_DECL nodes are chained through the DECL_CHAIN field, so this
actually is the head of this parameter list. */
tree gnu_param_list = NULL_TREE;
/* Likewise for the stub associated with an exported procedure. */
tree gnu_stub_param_list = NULL_TREE;
/* Non-null for subprograms containing parameters passed by copy-in
copy-out (Ada In Out or Out parameters not passed by reference),
in which case it is the list of nodes used to specify the values
......@@ -4119,8 +4100,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* If an import pragma asks to map this subprogram to a GCC builtin,
this is the builtin DECL node. */
tree gnu_builtin_decl = NULL_TREE;
/* For the stub associated with an exported procedure. */
tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
Entity_Id gnat_param;
enum inline_status_t inline_status
......@@ -4148,7 +4127,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
bool return_by_direct_ref_p = false;
bool return_by_invisi_ref_p = false;
bool return_unconstrained_p = false;
bool has_stub = false;
int parmnum;
/* A parameter may refer to this type, so defer completion of any
......@@ -4352,15 +4330,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* Otherwise, see if a Mechanism was supplied that forced this
parameter to be passed one way or another. */
else if (mech == Default
|| mech == By_Copy || mech == By_Reference)
|| mech == By_Copy
|| mech == By_Reference)
;
else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
mech = By_Descriptor;
else if (By_Short_Descriptor_Last <= mech &&
mech <= By_Short_Descriptor)
mech = By_Short_Descriptor;
else if (mech > 0)
{
if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
......@@ -4418,26 +4390,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (gnu_param)
{
/* If it's an exported subprogram, we build a parameter list
in parallel, in case we need to emit a stub for it. */
if (Is_Exported (gnat_entity))
{
gnu_stub_param_list
= chainon (gnu_param, gnu_stub_param_list);
/* Change By_Descriptor parameter to By_Reference for
the internal version of an exported subprogram. */
if (mech == By_Descriptor || mech == By_Short_Descriptor)
{
gnu_param
= gnat_to_gnu_param (gnat_param, By_Reference,
gnat_entity, false,
&copy_in_copy_out);
has_stub = true;
}
else
gnu_param = copy_node (gnu_param);
}
gnu_param_list = chainon (gnu_param, gnu_param_list);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_param));
......@@ -4572,8 +4524,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* The lists have been built in reverse. */
gnu_param_list = nreverse (gnu_param_list);
if (has_stub)
gnu_stub_param_list = nreverse (gnu_stub_param_list);
gnu_cico_list = nreverse (gnu_cico_list);
if (kind == E_Function)
......@@ -4587,13 +4537,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
return_by_direct_ref_p,
return_by_invisi_ref_p);
if (has_stub)
gnu_stub_type
= create_subprog_type (gnu_return_type, gnu_stub_param_list,
gnu_cico_list, return_unconstrained_p,
return_by_direct_ref_p,
return_by_invisi_ref_p);
/* A subprogram (something that doesn't return anything) shouldn't
be considered const since there would be no reason for such a
subprogram. Note that procedures with Out (or In Out) parameters
......@@ -4608,9 +4551,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
| (volatile_flag ? TYPE_QUAL_VOLATILE : 0);
gnu_type = change_qualified_type (gnu_type, quals);
if (has_stub)
gnu_stub_type = change_qualified_type (gnu_stub_type, quals);
}
/* If we have a builtin decl for that function, use it. Check if the
......@@ -4683,39 +4623,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
else
{
/* ??? When only the spec of a package is provided, downgrade
is_required to is_enabled to avoid issuing an error later. */
if (inline_status == is_required)
{
Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
if (Nkind (gnat_body) != N_Subprogram_Body
&& No (Corresponding_Body (gnat_body)))
inline_status = is_enabled;
}
if (has_stub)
{
gnu_stub_name = gnu_ext_name;
gnu_ext_name = create_concat_name (gnat_entity, "internal");
public_flag = false;
artificial_flag = true;
}
gnu_decl
= create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_param_list, inline_status,
public_flag, extern_flag, artificial_flag,
attr_list, gnat_entity);
if (has_stub)
{
tree gnu_stub_decl
= create_subprog_decl (gnu_entity_name, gnu_stub_name,
gnu_stub_type, gnu_stub_param_list,
inline_status, true, extern_flag,
false, attr_list, gnat_entity);
SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
}
/* This is unrelated to the stub built right above. */
DECL_STUBBED_P (gnu_decl)
= Convention (gnat_entity) == Convention_Stubbed;
......@@ -5663,7 +5575,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
{
tree gnu_param_name = get_entity_name (gnat_param);
tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
tree gnu_param_type_alt = NULL_TREE;
bool in_param = (Ekind (gnat_param) == E_In_Parameter);
/* The parameter can be indirectly modified if its address is taken. */
bool ro_param = in_param && !Address_Taken (gnat_param);
......@@ -5714,31 +5625,8 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
&& Is_Descendent_Of_Address (Etype (gnat_param)))
gnu_param_type = ptr_void_type_node;
/* VMS descriptors are themselves passed by reference. */
if (mech == By_Short_Descriptor ||
(mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !flag_vms_malloc64))
gnu_param_type
= build_pointer_type (build_vms_descriptor32 (gnu_param_type,
Mechanism (gnat_param),
gnat_subprog));
else if (mech == By_Descriptor)
{
/* Build both a 32-bit and 64-bit descriptor, one of which will be
chosen in fill_vms_descriptor. */
gnu_param_type_alt
= build_pointer_type (build_vms_descriptor32 (gnu_param_type,
Mechanism (gnat_param),
gnat_subprog));
gnu_param_type
= build_pointer_type (build_vms_descriptor (gnu_param_type,
Mechanism (gnat_param),
gnat_subprog));
}
/* Arrays are passed as pointers to element type for foreign conventions. */
else if (foreign
&& mech != By_Copy
&& TREE_CODE (gnu_param_type) == ARRAY_TYPE)
if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
{
/* Strip off any multi-dimensional entries, then strip
off the last array to get the component type. */
......@@ -5821,9 +5709,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
if (Ekind (gnat_param) == E_Out_Parameter
&& !by_ref
&& (by_return
|| (mech != By_Descriptor
&& mech != By_Short_Descriptor
&& !POINTER_TYPE_P (gnu_param_type)
|| (!POINTER_TYPE_P (gnu_param_type)
&& !AGGREGATE_TYPE_P (gnu_param_type)
&& !Has_Default_Aspect (Etype (gnat_param))))
&& !(Is_Array_Type (Etype (gnat_param))
......@@ -5835,16 +5721,10 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
ro_param || by_ref || by_component_ptr);
DECL_BY_REF_P (gnu_param) = by_ref;
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
DECL_BY_DESCRIPTOR_P (gnu_param)
= (mech == By_Descriptor || mech == By_Short_Descriptor);
DECL_POINTS_TO_READONLY_P (gnu_param)
= (ro_param && (by_ref || by_component_ptr));
DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
/* Save the alternate descriptor type, if any. */
if (gnu_param_type_alt)
SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
/* If no Mechanism was specified, indicate what we're using, then
back-annotate it. */
if (mech == Default)
......@@ -6307,6 +6187,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true, expr_public_p,
!definition, expr_global_p, !need_debug, NULL, gnat_entity);
DECL_ARTIFICIAL (gnu_decl) = 1;
if (use_variable)
return gnu_decl;
}
......@@ -8648,6 +8529,28 @@ copy_and_substitute_in_size (tree new_type, tree old_type,
TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
}
/* Add a parallel type to GNU_TYPE, the translation of GNAT_ENTITY, which is
the implementation type of a packed array type (Is_Packed_Array_Impl_Type).
The parallel type is the original array type if it has been translated. */
static void
add_parallel_type_for_packed_array (tree gnu_type, Entity_Id gnat_entity)
{
Entity_Id gnat_original_array_type
= Underlying_Type (Original_Array_Type (gnat_entity));
tree gnu_original_array_type;
if (!present_gnu_tree (gnat_original_array_type))
return;
gnu_original_array_type = gnat_to_gnu_type (gnat_original_array_type);
if (TYPE_IS_DUMMY_P (gnu_original_array_type))
return;
add_parallel_type (gnu_type, gnu_original_array_type);
}
/* Given a type T, a FIELD_DECL F, and a replacement value R, return a
type with all size expressions that contain F in a PLACEHOLDER_EXPR
updated by replacing F with R.
......
gcc/ada/gcc-interface/gigi.h
......@@ -395,10 +395,8 @@ enum standard_datatypes
ADT_sbitsize_unit_node,
/* Function declaration nodes for run-time functions for allocating memory.
Ada allocators cause calls to these functions to be generated. Malloc32
is used only on 64bit systems needing to allocate 32bit memory. */
Ada allocators cause calls to this function to be generated. */
ADT_malloc_decl,
ADT_malloc32_decl,
/* Likewise for freeing memory. */
ADT_free_decl,
......@@ -471,7 +469,6 @@ extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1];
#define sbitsize_one_node gnat_std_decls[(int) ADT_sbitsize_one_node]
#define sbitsize_unit_node gnat_std_decls[(int) ADT_sbitsize_unit_node]
#define malloc_decl gnat_std_decls[(int) ADT_malloc_decl]
#define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl]
#define free_decl gnat_std_decls[(int) ADT_free_decl]
#define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl]
#define parent_name_id gnat_std_decls[(int) ADT_parent_name_id]
......@@ -783,19 +780,6 @@ extern void rest_of_subprog_body_compilation (tree subprog_decl);
Return a constructor for the template. */
extern tree build_template (tree template_type, tree array_type, tree expr);
/* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify
a descriptor type, and the GCC type of an object. Each FIELD_DECL
in the type contains in its DECL_INITIAL the expression to use when
a constructor is made for the type. GNAT_ENTITY is a gnat node used
to print out an error message if the mechanism cannot be applied to
an object of that type and also for the name. */
extern tree build_vms_descriptor (tree type, Mechanism_Type mech,
Entity_Id gnat_entity);
/* Build a 32bit VMS descriptor from a Mechanism_Type. See above. */
extern tree build_vms_descriptor32 (tree type, Mechanism_Type mech,
Entity_Id gnat_entity);
/* Build a type to be used to represent an aliased object whose nominal type
is an unconstrained array. This consists of a RECORD_TYPE containing a
field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE.
......@@ -963,19 +947,6 @@ extern tree build_allocator (tree type, tree init, tree result_type,
Entity_Id gnat_proc, Entity_Id gnat_pool,
Node_Id gnat_node, bool);
/* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result.
GNAT_ACTUAL is the actual parameter for which the descriptor is built. */
extern tree fill_vms_descriptor (tree gnu_type, tree gnu_expr,
Node_Id gnat_actual);
/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit)
pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the
descriptor is passed. */
extern tree convert_vms_descriptor (tree gnu_type, tree gnu_expr,
tree gnu_expr_alt_type,
Entity_Id gnat_subprog);
/* Indicate that we need to take the address of T and that it therefore
should not be allocated in a register. Returns true if successful. */
extern bool gnat_mark_addressable (tree t);
......@@ -1067,19 +1038,6 @@ extern void enumerate_modes (void (*f) (const char *, int, int, int, int, int,
}
#endif
/* Let code know whether we are targeting VMS without need of
intrusive preprocessor directives. */
#ifndef TARGET_ABI_OPEN_VMS
#define TARGET_ABI_OPEN_VMS 0
#endif
/* VMS option set by default, when clear forces 32bit mallocs and 32bit
Descriptors. Always used in combination with TARGET_ABI_OPEN_VMS
so no effect on non-VMS systems. */
#if TARGET_ABI_OPEN_VMS == 0
#define flag_vms_malloc64 0
#endif
/* Convenient shortcuts. */
#define VECTOR_TYPE_P(TYPE) (TREE_CODE (TYPE) == VECTOR_TYPE)
......
gcc/ada/gcc-interface/misc.c
......@@ -407,10 +407,8 @@ gnat_init_gcc_fp (void)
flag_signed_zeros = 0;
/* Assume that FP operations can trap if S'Machine_Overflow is true,
but don't override the user if not.
??? Alpha/VMS enables FP traps without declaring it. */
if (Machine_Overflows_On_Target || TARGET_ABI_OPEN_VMS)
but don't override the user if not. */
if (Machine_Overflows_On_Target)
flag_trapping_math = 1;
else if (!global_options_set.x_flag_trapping_math)
flag_trapping_math = 0;
......@@ -469,8 +467,6 @@ gnat_print_type (FILE *file, tree node, int indent)
else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
indent + 4);
else if (TYPE_VAX_FLOATING_POINT_P (node))
;
else
print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
......
gcc/ada/gcc-interface/trans.c
......@@ -285,8 +285,7 @@ gigi (Node_Id gnat_root,
{
Node_Id gnat_iter;
Entity_Id gnat_literal;
tree long_long_float_type, exception_type, t, ftype;
tree int64_type = gnat_type_for_size (64, 0);
tree t, ftype, int64_type;
struct elab_info *info;
int i;
......@@ -304,10 +303,6 @@ gigi (Node_Id gnat_root,
type_annotate_only = (gigi_operating_mode == 1);
#if TARGET_ABI_OPEN_VMS
vms_float_format = Float_Format;
#endif
for (i = 0; i < number_file; i++)
{
/* Use the identifier table to make a permanent copy of the filename as
......@@ -412,14 +407,6 @@ gigi (Node_Id gnat_root,
NULL, Empty);
DECL_IS_MALLOC (malloc_decl) = 1;
/* malloc32 is a function declaration tree for a function to allocate
32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */
malloc32_decl
= create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
ftype, NULL_TREE, is_disabled, true, true, true,
NULL, Empty);
DECL_IS_MALLOC (malloc32_decl) = 1;
/* free is a function declaration tree for a function to free memory. */
free_decl
= create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
......@@ -430,6 +417,7 @@ gigi (Node_Id gnat_root,
Empty);
/* This is used for 64-bit multiplication with overflow checking. */
int64_type = gnat_type_for_size (64, 0);
mulv64_decl
= create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
build_function_type_list (int64_type, int64_type,
......@@ -557,9 +545,7 @@ gigi (Node_Id gnat_root,
}
/* Set the types that GCC and Gigi use from the front end. */
exception_type
= gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
except_type_node = TREE_TYPE (exception_type);
except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type));
/* Make other functions used for exception processing. */
get_excptr_decl
......@@ -624,21 +610,8 @@ gigi (Node_Id gnat_root,
null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
}
long_long_float_type
= gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
{
/* In this case, the builtin floating point types are VAX float,
so make up a type for use. */
longest_float_type_node = make_node (REAL_TYPE);
TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
layout_type (longest_float_type_node);
record_builtin_type ("longest float type", longest_float_type_node,
false);
}
else
longest_float_type_node = TREE_TYPE (long_long_float_type);
longest_float_type_node
= get_unpadded_type (Base_Type (standard_long_long_float));
/* Dummy objects to materialize "others" and "all others" in the exception
tables. These are exported by a-exexpr-gcc.adb, so see this unit for
......@@ -1497,6 +1470,38 @@ Pragma_to_gnu (Node_Id gnat_node)
return gnu_result;
}
/* Return an expression for the length of TYPE, an integral type, computed in
RESULT_TYPE, another integral type.
We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
which would only overflow in much rarer cases, for extremely large arrays
we expect never to encounter in practice. Besides, the former computation
required the use of potentially constraining signed arithmetics while the
latter does not. Note that the comparison must be done in the original
base index type in order to avoid any overflow during the conversion. */
static tree
get_type_length (tree type, tree result_type)
{
tree comp_type = get_base_type (result_type);
tree base_type = get_base_type (type);
tree lb = convert (base_type, TYPE_MIN_VALUE (type));
tree hb = convert (base_type, TYPE_MAX_VALUE (type));
tree length
= build_binary_op (PLUS_EXPR, comp_type,
build_binary_op (MINUS_EXPR, comp_type,
convert (comp_type, hb),
convert (comp_type, lb)),
convert (comp_type, integer_one_node));
length
= build_cond_expr (result_type,
build_binary_op (GE_EXPR, boolean_type_node, hb, lb),
convert (result_type, length),
convert (result_type, integer_zero_node));
return length;
}
/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
where we should place the result type. ATTRIBUTE is the attribute ID. */
......@@ -1886,20 +1891,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
else if (attribute == Attr_Last)
gnu_result = TYPE_MAX_VALUE (gnu_type);
else
gnu_result
= build_binary_op
(MAX_EXPR, get_base_type (gnu_result_type),
build_binary_op
(PLUS_EXPR, get_base_type (gnu_result_type),
build_binary_op (MINUS_EXPR,
get_base_type (gnu_result_type),
convert (gnu_result_type,
TYPE_MAX_VALUE (gnu_type)),
convert (gnu_result_type,
TYPE_MIN_VALUE (gnu_type))),
convert (gnu_result_type, integer_one_node)),
convert (gnu_result_type, integer_zero_node));
gnu_result = get_type_length (gnu_type, gnu_result_type);
break;
}
......@@ -2031,37 +2023,10 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
gnu_result = pa->length;
break;
}
else
{
/* We used to compute the length as max (hb - lb + 1, 0),
which could overflow for some cases of empty arrays, e.g.
when lb == index_type'first. We now compute the length as
(hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
much rarer cases, for extremely large arrays we expect
never to encounter in practice. In addition, the former
computation required the use of potentially constraining
signed arithmetic while the latter doesn't. Note that
the comparison must be done in the original index type,
to avoid any overflow during the conversion. */
tree comp_type = get_base_type (gnu_result_type);
tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
tree lb = TYPE_MIN_VALUE (index_type);
tree hb = TYPE_MAX_VALUE (index_type);
gnu_result
= build_binary_op (PLUS_EXPR, comp_type,
build_binary_op (MINUS_EXPR,
comp_type,
convert (comp_type, hb),
convert (comp_type, lb)),
convert (comp_type, integer_one_node));
gnu_result
= build_cond_expr (comp_type,
build_binary_op (GE_EXPR,
boolean_type_node,
hb, lb),
gnu_result,
convert (comp_type, integer_zero_node));
}
= get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)),
gnu_result_type);
}
/* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
......@@ -2334,14 +2299,16 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
case Attr_Machine:
/* The trick is to force the compiler to store the result in memory so
that we do not have extra precision used. But do this only when this
is necessary, i.e. for a type that is not the longest floating-point
type and if FP_ARITH_MAY_WIDEN is true. */
is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
the type is lower than that of the longest floating-point type. */
prefix_unused = true;
gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = convert (gnu_result_type, gnu_expr);
if (gnu_result_type != longest_float_type_node && fp_arith_may_widen)
if (fp_arith_may_widen
&& TYPE_PRECISION (gnu_result_type)
< TYPE_PRECISION (longest_float_type_node))
{
tree rec_type = make_node (RECORD_TYPE);
tree field
......@@ -2677,8 +2644,8 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
enum tree_code update_code, test_code, shift_code;
bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
gnu_low = TYPE_MIN_VALUE (gnu_type);
gnu_high = TYPE_MAX_VALUE (gnu_type);
gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type));
gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type));
/* We must disable modulo reduction for the iteration variable, if any,
in order for the loop comparison to be effective. */
......@@ -2971,61 +2938,6 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
return gnu_result;
}
/* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
handler for the current function. */
/* This is implemented by issuing a call to the appropriate VMS specific
builtin. To avoid having VMS specific sections in the global gigi decls
array, we maintain the decls of interest here. We can't declare them
inside the function because we must mark them never to be GC'd, which we
can only do at the global level. */
static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
static void
establish_gnat_vms_condition_handler (void)
{
tree establish_stmt;
/* Elaborate the required decls on the first call. Check on the decl for
the gnat condition handler to decide, as this is one we create so we are
sure that it will be non null on subsequent calls. The builtin decl is
looked up so remains null on targets where it is not implemented yet. */
if (gnat_vms_condition_handler_decl == NULL_TREE)
{
vms_builtin_establish_handler_decl
= builtin_decl_for
(get_identifier ("__builtin_establish_vms_condition_handler"));
gnat_vms_condition_handler_decl
= create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
NULL_TREE,
build_function_type_list (boolean_type_node,
ptr_void_type_node,
ptr_void_type_node,
NULL_TREE),
NULL_TREE, is_disabled, true, true, true, NULL,
Empty);
/* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */
DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
}
/* Do nothing if the establish builtin is not available, which might happen
on targets where the facility is not implemented. */
if (vms_builtin_establish_handler_decl == NULL_TREE)
return;
establish_stmt
= build_call_n_expr (vms_builtin_establish_handler_decl, 1,
build_unary_op
(ADDR_EXPR, NULL_TREE,
gnat_vms_condition_handler_decl));
add_stmt (establish_stmt);
}
/* This page implements a form of Named Return Value optimization modelled
on the C++ optimization of the same name. The main difference is that
we disregard any semantical considerations when applying it here, the
......@@ -3520,69 +3432,6 @@ build_return_expr (tree ret_obj, tree ret_val)
return build1 (RETURN_EXPR, void_type_node, result_expr);
}
/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
and the GNAT node GNAT_SUBPROG. */
static void
build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
{
tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
tree gnu_subprog_param, gnu_stub_param, gnu_param;
tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
vec<tree, va_gc> *gnu_param_vec = NULL;
gnu_subprog_type = TREE_TYPE (gnu_subprog);
/* Initialize the information structure for the function. */
allocate_struct_function (gnu_stub_decl, false);
set_cfun (NULL);
begin_subprog_body (gnu_stub_decl);
start_stmt_group ();
gnat_pushlevel ();
/* Loop over the parameters of the stub and translate any of them
passed by descriptor into a by reference one. */
for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog);
gnu_stub_param;
gnu_stub_param = DECL_CHAIN (gnu_stub_param),
gnu_subprog_param = DECL_CHAIN (gnu_subprog_param))
{
if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
{
gcc_assert (DECL_BY_REF_P (gnu_subprog_param));
gnu_param
= convert_vms_descriptor (TREE_TYPE (gnu_subprog_param),
gnu_stub_param,
DECL_PARM_ALT_TYPE (gnu_stub_param),
gnat_subprog);
}
else
gnu_param = gnu_stub_param;
vec_safe_push (gnu_param_vec, gnu_param);
}
/* Invoke the internal subprogram. */
gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
gnu_subprog);
gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type),
gnu_subprog_addr, gnu_param_vec);
/* Propagate the return value, if any. */
if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
add_stmt (gnu_subprog_call);
else
add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl),
gnu_subprog_call));
gnat_poplevel ();
end_subprog_body (end_stmt_group ());
rest_of_subprog_body_compilation (gnu_stub_decl);
}
/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
don't return anything. */
......@@ -3730,22 +3579,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
start_stmt_group ();
gnat_pushlevel ();
/* On VMS, establish our condition handler to possibly turn a condition into
the corresponding exception if the subprogram has a foreign convention or
is exported.
To ensure proper execution of local finalizations on condition instances,
we must turn a condition into the corresponding exception even if there
is no applicable Ada handler, and need at least one condition handler per
possible call chain involving GNAT code. OTOH, establishing the handler
has a cost so we want to minimize the number of subprograms into which
this happens. The foreign or exported condition is expected to satisfy
all the constraints. */
if (TARGET_ABI_OPEN_VMS
&& (Has_Foreign_Convention (gnat_subprog_id)
|| Is_Exported (gnat_subprog_id)))
establish_gnat_vms_condition_handler ();
process_decls (Declarations (gnat_node), Empty, Empty, true, true);
/* Generate the code of the subprogram itself. A return statement will be
......@@ -3878,10 +3711,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
}
rest_of_subprog_body_compilation (gnu_subprog_decl);
/* If there is a stub associated with the function, build it now. */
if (DECL_FUNCTION_STUB (gnu_subprog_decl))
build_function_stub (gnu_subprog_decl, gnat_subprog_id);
}
/* Return true if GNAT_NODE requires atomic synchronization. */
......@@ -4093,8 +3922,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
const bool is_by_ref_formal_parm
= is_true_formal_parm
&& (DECL_BY_REF_P (gnu_formal)
|| DECL_BY_COMPONENT_PTR_P (gnu_formal)
|| DECL_BY_DESCRIPTOR_P (gnu_formal));
|| DECL_BY_COMPONENT_PTR_P (gnu_formal));
/* In the Out or In Out case, we must suppress conversions that yield
an lvalue but can nevertheless cause the creation of a temporary,
because we need the real object in this case, either to pass its
......@@ -4351,24 +4179,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
}
/* Then see if the parameter is passed by descriptor. */
else if (is_true_formal_parm && DECL_BY_DESCRIPTOR_P (gnu_formal))
{
gnu_actual = convert (gnu_formal_type, gnu_actual);
/* If this is 'Null_Parameter, pass a zero descriptor. */
if ((TREE_CODE (gnu_actual) == INDIRECT_REF
|| TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
&& TREE_PRIVATE (gnu_actual))
gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
else
gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
fill_vms_descriptor
(TREE_TYPE (TREE_TYPE (gnu_formal)),
gnu_actual, gnat_actual));
}
/* Otherwise the parameter is passed by copy. */
else
{
......@@ -4482,10 +4292,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
if (!(present_gnu_tree (gnat_formal)
&& TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
&& (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
|| (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
&& ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
|| (DECL_BY_DESCRIPTOR_P
(get_gnu_tree (gnat_formal))))))))
|| DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))))
&& Ekind (gnat_formal) != E_In_Parameter)
{
/* Get the value to assign to this Out or In Out parameter. It is
......@@ -4986,9 +4793,6 @@ Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
/* The Non_Ada_Error case for VMS exceptions is handled
by the personality routine. */
}
else
gcc_unreachable ();
......@@ -5943,25 +5747,16 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Selected_Component:
{
tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
Entity_Id gnat_prefix = Prefix (gnat_node);
Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
tree gnu_prefix = gnat_to_gnu (gnat_prefix);
tree gnu_field;
while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
|| IN (Ekind (gnat_pref_type), Access_Kind))
{
if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
gnat_pref_type = Underlying_Type (gnat_pref_type);
else if (IN (Ekind (gnat_pref_type), Access_Kind))
gnat_pref_type = Designated_Type (gnat_pref_type);
}
gnu_prefix = maybe_implicit_deref (gnu_prefix);
/* For discriminant references in tagged types always substitute the
corresponding discriminant as the actual selected component. */
if (Is_Tagged_Type (gnat_pref_type))
if (Is_Tagged_Type (Etype (gnat_prefix)))
while (Present (Corresponding_Discriminant (gnat_field)))
gnat_field = Corresponding_Discriminant (gnat_field);
......@@ -6170,9 +5965,12 @@ gnat_to_gnu (Node_Id gnat_node)
|| Nkind (gnat_range) == N_Expanded_Name)
{
tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
tree gnu_range_base_type = get_base_type (gnu_range_type);
gnu_low = TYPE_MIN_VALUE (gnu_range_type);
gnu_high = TYPE_MAX_VALUE (gnu_range_type);
gnu_low
= convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
gnu_high
= convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
}
else
gcc_unreachable ();
......@@ -8625,11 +8423,12 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
tree gnu_base_type = get_base_type (gnu_type);
tree gnu_result = gnu_expr;
/* If we are not doing any checks, the output is an integral type, and
the input is not a floating type, just do the conversion. This
shortcut is required to avoid problems with packed array types
and simplifies code in all cases anyway. */
if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
/* If we are not doing any checks, the output is an integral type and the
input is not a floating-point type, just do the conversion. This is
required for packed array types and is simpler in all cases anyway. */
if (!rangep
&& !overflowp
&& INTEGRAL_TYPE_P (gnu_base_type)
&& !FLOAT_TYPE_P (gnu_in_type))
return convert (gnu_type, gnu_expr);
......@@ -8730,10 +8529,6 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
calc_type
= fp_arith_may_widen ? longest_float_type_node : gnu_in_basetype;
/* FIXME: Should not have padding in the first place. */
if (TYPE_IS_PADDING_P (calc_type))
calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
/* Compute the exact value calc_type'Pred (0.5) at compile time. */
fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
......
gcc/ada/gcc-interface/utils.c
......@@ -954,12 +954,8 @@ make_type_from_size (tree type, tree size_tree, bool for_biased)
else
new_type = make_signed_type (size);
TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
SET_TYPE_RM_MIN_VALUE (new_type,
convert (TREE_TYPE (new_type),
TYPE_MIN_VALUE (type)));
SET_TYPE_RM_MAX_VALUE (new_type,
convert (TREE_TYPE (new_type),
TYPE_MAX_VALUE (type)));
SET_TYPE_RM_MIN_VALUE (new_type, TYPE_MIN_VALUE (type));
SET_TYPE_RM_MAX_VALUE (new_type, TYPE_MAX_VALUE (type));
/* Copy the name to show that it's essentially the same type and
not a subrange type. */
TYPE_NAME (new_type) = TYPE_NAME (type);
......@@ -2051,8 +2047,8 @@ create_range_type (tree type, tree min, tree max)
TYPE_MAX_VALUE (type));
/* Then set the actual range. */
SET_TYPE_RM_MIN_VALUE (range_type, convert (type, min));
SET_TYPE_RM_MAX_VALUE (range_type, convert (type, max));
SET_TYPE_RM_MIN_VALUE (range_type, min);
SET_TYPE_RM_MAX_VALUE (range_type, max);
return range_type;
}
......@@ -2738,6 +2734,7 @@ create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type,
tree_cons (get_identifier ("always_inline"),
NULL_TREE, NULL_TREE),
ATTR_FLAG_TYPE_IN_PLACE);
/* ... fall through ... */
case is_enabled:
......@@ -3108,12 +3105,14 @@ max_size (tree exp, bool max_p)
case tcc_reference:
/* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
modify. Otherwise, we treat it like a variable. */
if (!CONTAINS_PLACEHOLDER_P (exp))
return exp;
if (CONTAINS_PLACEHOLDER_P (exp))
{
tree val_type = TREE_TYPE (TREE_OPERAND (exp, 1));
tree val = (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
return max_size (convert (get_base_type (val_type), val), true);
}
type = TREE_TYPE (TREE_OPERAND (exp, 1));
return
max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true);
return exp;
case tcc_comparison:
return max_p ? size_one_node : size_zero_node;
......@@ -3343,962 +3342,6 @@ build_vector_type_for_array (tree array_type, tree attribute)
return vector_type;
}
/* Helper routine to make a descriptor field. FIELD_LIST is the list of decls
being built; the new decl is chained on to the front of the list. */
static tree
make_descriptor_field (const char *name, tree type, tree rec_type,
tree initial, tree field_list)
{
tree field
= create_field_decl (get_identifier (name), type, rec_type, NULL_TREE,
NULL_TREE, 0, 0);
DECL_INITIAL (field) = initial;
DECL_CHAIN (field) = field_list;
return field;
}
/* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a
descriptor type, and the GCC type of an object. Each FIELD_DECL in the
type contains in its DECL_INITIAL the expression to use when a constructor
is made for the type. GNAT_ENTITY is an entity used to print out an error
message if the mechanism cannot be applied to an object of that type and
also for the name. */
tree
build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
{
tree record_type = make_node (RECORD_TYPE);
tree pointer32_type, pointer64_type;
tree field_list = NULL_TREE;
int klass, ndim, i, dtype = 0;
tree inner_type, tem;
tree *idx_arr;
/* If TYPE is an unconstrained array, use the underlying array type. */
if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
/* If this is an array, compute the number of dimensions in the array,
get the index types, and point to the inner type. */
if (TREE_CODE (type) != ARRAY_TYPE)
ndim = 0;
else
for (ndim = 1, inner_type = type;
TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
ndim++, inner_type = TREE_TYPE (inner_type))
;
idx_arr = XALLOCAVEC (tree, ndim);
if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA
&& TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
for (i = ndim - 1, inner_type = type;
i >= 0;
i--, inner_type = TREE_TYPE (inner_type))
idx_arr[i] = TYPE_DOMAIN (inner_type);
else
for (i = 0, inner_type = type;
i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
idx_arr[i] = TYPE_DOMAIN (inner_type);
/* Now get the DTYPE value. */
switch (TREE_CODE (type))
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
case BOOLEAN_TYPE:
if (TYPE_VAX_FLOATING_POINT_P (type))
switch (tree_to_uhwi (TYPE_DIGITS_VALUE (type)))
{
case 6:
dtype = 10;
break;
case 9:
dtype = 11;
break;
case 15:
dtype = 27;
break;
}
else
switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
{
case 8:
dtype = TYPE_UNSIGNED (type) ? 2 : 6;
break;
case 16:
dtype = TYPE_UNSIGNED (type) ? 3 : 7;
break;
case 32:
dtype = TYPE_UNSIGNED (type) ? 4 : 8;
break;
case 64:
dtype = TYPE_UNSIGNED (type) ? 5 : 9;
break;
case 128:
dtype = TYPE_UNSIGNED (type) ? 25 : 26;
break;
}
break;
case REAL_TYPE:
dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
break;
case COMPLEX_TYPE:
if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (type))
switch (tree_to_uhwi (TYPE_DIGITS_VALUE (type)))
{
case 6:
dtype = 12;
break;
case 9:
dtype = 13;
break;
case 15:
dtype = 29;
}
else
dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
break;
case ARRAY_TYPE:
dtype = 14;
break;
default:
break;
}
/* Get the CLASS value. */
switch (mech)
{
case By_Descriptor_A:
case By_Short_Descriptor_A:
klass = 4;
break;
case By_Descriptor_NCA:
case By_Short_Descriptor_NCA:
klass = 10;
break;
case By_Descriptor_SB:
case By_Short_Descriptor_SB:
klass = 15;
break;
case By_Descriptor:
case By_Short_Descriptor:
case By_Descriptor_S:
case By_Short_Descriptor_S:
default:
klass = 1;
break;
}
/* Make the type for a descriptor for VMS. The first four fields are the
same for all types. */
field_list
= make_descriptor_field ("LENGTH", gnat_type_for_size (16, 1), record_type,
size_in_bytes ((mech == By_Descriptor_A
|| mech == By_Short_Descriptor_A)
? inner_type : type),
field_list);
field_list
= make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1), record_type,
size_int (dtype), field_list);
field_list
= make_descriptor_field ("CLASS", gnat_type_for_size (8, 1), record_type,
size_int (klass), field_list);
pointer32_type = build_pointer_type_for_mode (type, SImode, false);
pointer64_type = build_pointer_type_for_mode (type, DImode, false);
/* Ensure that only 32-bit pointers are passed in 32-bit descriptors. Note
that we cannot build a template call to the CE routine as it would get a
wrong source location; instead we use a second placeholder for it. */
tem = build_unary_op (ADDR_EXPR, pointer64_type,
build0 (PLACEHOLDER_EXPR, type));
tem = build3 (COND_EXPR, pointer32_type,
Pmode != SImode
? build_binary_op (GE_EXPR, boolean_type_node, tem,
build_int_cstu (pointer64_type, 0x80000000))
: boolean_false_node,
build0 (PLACEHOLDER_EXPR, void_type_node),
convert (pointer32_type, tem));
field_list
= make_descriptor_field ("POINTER", pointer32_type, record_type, tem,
field_list);
switch (mech)
{
case By_Descriptor:
case By_Short_Descriptor:
case By_Descriptor_S:
case By_Short_Descriptor_S:
break;
case By_Descriptor_SB:
case By_Short_Descriptor_SB:
field_list
= make_descriptor_field ("SB_L1", gnat_type_for_size (32, 1),
record_type,
(TREE_CODE (type) == ARRAY_TYPE
? TYPE_MIN_VALUE (TYPE_DOMAIN (type))
: size_zero_node),
field_list);
field_list
= make_descriptor_field ("SB_U1", gnat_type_for_size (32, 1),
record_type,
(TREE_CODE (type) == ARRAY_TYPE
? TYPE_MAX_VALUE (TYPE_DOMAIN (type))
: size_zero_node),
field_list);
break;
case By_Descriptor_A:
case By_Short_Descriptor_A:
case By_Descriptor_NCA:
case By_Short_Descriptor_NCA:
field_list
= make_descriptor_field ("SCALE", gnat_type_for_size (8, 1),
record_type, size_zero_node, field_list);
field_list
= make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1),
record_type, size_zero_node, field_list);
field_list
= make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1),
record_type,
size_int ((mech == By_Descriptor_NCA
|| mech == By_Short_Descriptor_NCA)
? 0
/* Set FL_COLUMN, FL_COEFF, and
FL_BOUNDS. */
: (TREE_CODE (type) == ARRAY_TYPE
&& TYPE_CONVENTION_FORTRAN_P
(type)
? 224 : 192)),
field_list);
field_list
= make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1),
record_type, size_int (ndim), field_list);
field_list
= make_descriptor_field ("ARSIZE", gnat_type_for_size (32, 1),
record_type, size_in_bytes (type),
field_list);
/* Now build a pointer to the 0,0,0... element. */
tem = build0 (PLACEHOLDER_EXPR, type);
for (i = 0, inner_type = type; i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
convert (TYPE_DOMAIN (inner_type), size_zero_node),
NULL_TREE, NULL_TREE);
field_list
= make_descriptor_field ("A0", pointer32_type, record_type,
build1 (ADDR_EXPR, pointer32_type, tem),
field_list);
/* Next come the addressing coefficients. */
tem = size_one_node;
for (i = 0; i < ndim; i++)
{
char fname[3];
tree idx_length
= size_binop (MULT_EXPR, tem,
size_binop (PLUS_EXPR,
size_binop (MINUS_EXPR,
TYPE_MAX_VALUE (idx_arr[i]),
TYPE_MIN_VALUE (idx_arr[i])),
size_int (1)));
fname[0] = ((mech == By_Descriptor_NCA ||
mech == By_Short_Descriptor_NCA) ? 'S' : 'M');
fname[1] = '0' + i, fname[2] = 0;
field_list
= make_descriptor_field (fname, gnat_type_for_size (32, 1),
record_type, idx_length, field_list);
if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA)
tem = idx_length;
}
/* Finally here are the bounds. */
for (i = 0; i < ndim; i++)
{
char fname[3];
fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
field_list
= make_descriptor_field (fname, gnat_type_for_size (32, 1),
record_type, TYPE_MIN_VALUE (idx_arr[i]),
field_list);
fname[0] = 'U';
field_list
= make_descriptor_field (fname, gnat_type_for_size (32, 1),
record_type, TYPE_MAX_VALUE (idx_arr[i]),
field_list);
}
break;
default:
post_error ("unsupported descriptor type for &", gnat_entity);
}
TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC");
finish_record_type (record_type, nreverse (field_list), 0, false);
return record_type;
}
/* Build a 64-bit VMS descriptor from a Mechanism_Type, which must specify a
descriptor type, and the GCC type of an object. Each FIELD_DECL in the
type contains in its DECL_INITIAL the expression to use when a constructor
is made for the type. GNAT_ENTITY is an entity used to print out an error
message if the mechanism cannot be applied to an object of that type and
also for the name. */
tree
build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
{
tree record_type = make_node (RECORD_TYPE);
tree pointer64_type;
tree field_list = NULL_TREE;
int klass, ndim, i, dtype = 0;
tree inner_type, tem;
tree *idx_arr;
/* If TYPE is an unconstrained array, use the underlying array type. */
if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
/* If this is an array, compute the number of dimensions in the array,
get the index types, and point to the inner type. */
if (TREE_CODE (type) != ARRAY_TYPE)
ndim = 0;
else
for (ndim = 1, inner_type = type;
TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
ndim++, inner_type = TREE_TYPE (inner_type))
;
idx_arr = XALLOCAVEC (tree, ndim);
if (mech != By_Descriptor_NCA
&& TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
for (i = ndim - 1, inner_type = type;
i >= 0;
i--, inner_type = TREE_TYPE (inner_type))
idx_arr[i] = TYPE_DOMAIN (inner_type);
else
for (i = 0, inner_type = type;
i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
idx_arr[i] = TYPE_DOMAIN (inner_type);
/* Now get the DTYPE value. */
switch (TREE_CODE (type))
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
case BOOLEAN_TYPE:
if (TYPE_VAX_FLOATING_POINT_P (type))
switch (tree_to_uhwi (TYPE_DIGITS_VALUE (type)))
{
case 6:
dtype = 10;
break;
case 9:
dtype = 11;
break;
case 15:
dtype = 27;
break;
}
else
switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
{
case 8:
dtype = TYPE_UNSIGNED (type) ? 2 : 6;
break;
case 16:
dtype = TYPE_UNSIGNED (type) ? 3 : 7;
break;
case 32:
dtype = TYPE_UNSIGNED (type) ? 4 : 8;
break;
case 64:
dtype = TYPE_UNSIGNED (type) ? 5 : 9;
break;
case 128:
dtype = TYPE_UNSIGNED (type) ? 25 : 26;
break;
}
break;
case REAL_TYPE:
dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
break;
case COMPLEX_TYPE:
if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (type))
switch (tree_to_uhwi (TYPE_DIGITS_VALUE (type)))
{
case 6:
dtype = 12;
break;
case 9:
dtype = 13;
break;
case 15:
dtype = 29;
}
else
dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
break;
case ARRAY_TYPE:
dtype = 14;
break;
default:
break;
}
/* Get the CLASS value. */
switch (mech)
{
case By_Descriptor_A:
klass = 4;
break;
case By_Descriptor_NCA:
klass = 10;
break;
case By_Descriptor_SB:
klass = 15;
break;
case By_Descriptor:
case By_Descriptor_S:
default:
klass = 1;
break;
}
/* Make the type for a 64-bit descriptor for VMS. The first six fields
are the same for all types. */
field_list
= make_descriptor_field ("MBO", gnat_type_for_size (16, 1),
record_type, size_int (1), field_list);
field_list
= make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1),
record_type, size_int (dtype), field_list);
field_list
= make_descriptor_field ("CLASS", gnat_type_for_size (8, 1),
record_type, size_int (klass), field_list);
field_list
= make_descriptor_field ("MBMO", gnat_type_for_size (32, 1),
record_type, size_int (-1), field_list);
field_list
= make_descriptor_field ("LENGTH", gnat_type_for_size (64, 1),
record_type,
size_in_bytes (mech == By_Descriptor_A
? inner_type : type),
field_list);
pointer64_type = build_pointer_type_for_mode (type, DImode, false);
field_list
= make_descriptor_field ("POINTER", pointer64_type, record_type,
build_unary_op (ADDR_EXPR, pointer64_type,
build0 (PLACEHOLDER_EXPR, type)),
field_list);
switch (mech)
{
case By_Descriptor:
case By_Descriptor_S:
break;
case By_Descriptor_SB:
field_list
= make_descriptor_field ("SB_L1", gnat_type_for_size (64, 1),
record_type,
(TREE_CODE (type) == ARRAY_TYPE
? TYPE_MIN_VALUE (TYPE_DOMAIN (type))
: size_zero_node),
field_list);
field_list
= make_descriptor_field ("SB_U1", gnat_type_for_size (64, 1),
record_type,
(TREE_CODE (type) == ARRAY_TYPE
? TYPE_MAX_VALUE (TYPE_DOMAIN (type))
: size_zero_node),
field_list);
break;
case By_Descriptor_A:
case By_Descriptor_NCA:
field_list
= make_descriptor_field ("SCALE", gnat_type_for_size (8, 1),
record_type, size_zero_node, field_list);
field_list
= make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1),
record_type, size_zero_node, field_list);
dtype = (mech == By_Descriptor_NCA
? 0
/* Set FL_COLUMN, FL_COEFF, and
FL_BOUNDS. */
: (TREE_CODE (type) == ARRAY_TYPE
&& TYPE_CONVENTION_FORTRAN_P (type)
? 224 : 192));
field_list
= make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1),
record_type, size_int (dtype),
field_list);
field_list
= make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1),
record_type, size_int (ndim), field_list);
field_list
= make_descriptor_field ("MBZ", gnat_type_for_size (32, 1),
record_type, size_int (0), field_list);
field_list
= make_descriptor_field ("ARSIZE", gnat_type_for_size (64, 1),
record_type, size_in_bytes (type),
field_list);
/* Now build a pointer to the 0,0,0... element. */
tem = build0 (PLACEHOLDER_EXPR, type);
for (i = 0, inner_type = type; i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
convert (TYPE_DOMAIN (inner_type), size_zero_node),
NULL_TREE, NULL_TREE);
field_list
= make_descriptor_field ("A0", pointer64_type, record_type,
build1 (ADDR_EXPR, pointer64_type, tem),
field_list);
/* Next come the addressing coefficients. */
tem = size_one_node;
for (i = 0; i < ndim; i++)
{
char fname[3];
tree idx_length
= size_binop (MULT_EXPR, tem,
size_binop (PLUS_EXPR,
size_binop (MINUS_EXPR,
TYPE_MAX_VALUE (idx_arr[i]),
TYPE_MIN_VALUE (idx_arr[i])),
size_int (1)));
fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
fname[1] = '0' + i, fname[2] = 0;
field_list
= make_descriptor_field (fname, gnat_type_for_size (64, 1),
record_type, idx_length, field_list);
if (mech == By_Descriptor_NCA)
tem = idx_length;
}
/* Finally here are the bounds. */
for (i = 0; i < ndim; i++)
{
char fname[3];
fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
field_list
= make_descriptor_field (fname, gnat_type_for_size (64, 1),
record_type,
TYPE_MIN_VALUE (idx_arr[i]), field_list);
fname[0] = 'U';
field_list
= make_descriptor_field (fname, gnat_type_for_size (64, 1),
record_type,
TYPE_MAX_VALUE (idx_arr[i]), field_list);
}
break;
default:
post_error ("unsupported descriptor type for &", gnat_entity);
}
TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC64");
finish_record_type (record_type, nreverse (field_list), 0, false);
return record_type;
}
/* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result.
GNAT_ACTUAL is the actual parameter for which the descriptor is built. */
tree
fill_vms_descriptor (tree gnu_type, tree gnu_expr, Node_Id gnat_actual)
{
vec<constructor_elt, va_gc> *v = NULL;
tree field;
gnu_expr = maybe_unconstrained_array (gnu_expr);
gnu_expr = gnat_protect_expr (gnu_expr);
gnat_mark_addressable (gnu_expr);
/* We may need to substitute both GNU_EXPR and a CALL_EXPR to the raise CE
routine in case we have a 32-bit descriptor. */
gnu_expr = build2 (COMPOUND_EXPR, void_type_node,
build_call_raise (CE_Range_Check_Failed, gnat_actual,
N_Raise_Constraint_Error),
gnu_expr);
for (field = TYPE_FIELDS (gnu_type); field; field = DECL_CHAIN (field))
{
tree value
= convert (TREE_TYPE (field),
SUBSTITUTE_PLACEHOLDER_IN_EXPR (DECL_INITIAL (field),
gnu_expr));
CONSTRUCTOR_APPEND_ELT (v, field, value);
}
return gnat_build_constructor (gnu_type, v);
}
/* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a
regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to
which the VMS descriptor is passed. */
static tree
convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
{
tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
/* The CLASS field is the 3rd field in the descriptor. */
tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type)));
/* The POINTER field is the 6th field in the descriptor. */
tree pointer = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (klass)));
/* Retrieve the value of the POINTER field. */
tree gnu_expr64
= build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
if (POINTER_TYPE_P (gnu_type))
return convert (gnu_type, gnu_expr64);
else if (TYPE_IS_FAT_POINTER_P (gnu_type))
{
tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
tree p_bounds_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
tree template_type = TREE_TYPE (p_bounds_type);
tree min_field = TYPE_FIELDS (template_type);
tree max_field = DECL_CHAIN (TYPE_FIELDS (template_type));
tree template_tree, template_addr, aflags, dimct, t, u;
/* See the head comment of build_vms_descriptor. */
int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
tree lfield, ufield;
vec<constructor_elt, va_gc> *v;
/* Convert POINTER to the pointer-to-array type. */
gnu_expr64 = convert (p_array_type, gnu_expr64);
switch (iklass)
{
case 1: /* Class S */
case 15: /* Class SB */
/* Build {1, LENGTH} template; LENGTH64 is the 5th field. */
vec_alloc (v, 2);
t = DECL_CHAIN (DECL_CHAIN (klass));
t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
CONSTRUCTOR_APPEND_ELT (v, min_field,
convert (TREE_TYPE (min_field),
integer_one_node));
CONSTRUCTOR_APPEND_ELT (v, max_field,
convert (TREE_TYPE (max_field), t));
template_tree = gnat_build_constructor (template_type, v);
template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
/* For class S, we are done. */
if (iklass == 1)
break;
/* Test that we really have a SB descriptor, like DEC Ada. */
t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
u = build_binary_op (EQ_EXPR, boolean_type_node, t, u);
/* If so, there is already a template in the descriptor and
it is located right after the POINTER field. The fields are
64bits so they must be repacked. */
t = DECL_CHAIN (pointer);
lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
t = DECL_CHAIN (t);
ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
ufield = convert
(TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield);
/* Build the template in the form of a constructor. */
vec_alloc (v, 2);
CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield);
CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (template_type)),
ufield);
template_tree = gnat_build_constructor (template_type, v);
/* Otherwise use the {1, LENGTH} template we build above. */
template_addr = build3 (COND_EXPR, p_bounds_type, u,
build_unary_op (ADDR_EXPR, p_bounds_type,
template_tree),
template_addr);
break;
case 4: /* Class A */
/* The AFLAGS field is the 3rd field after the pointer in the
descriptor. */
t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer)));
aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
/* The DIMCT field is the next field in the descriptor after
aflags. */
t = DECL_CHAIN (t);
dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
/* Raise CONSTRAINT_ERROR if either more than 1 dimension
or FL_COEFF or FL_BOUNDS not set. */
u = build_int_cst (TREE_TYPE (aflags), 192);
u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node,
build_binary_op (NE_EXPR, boolean_type_node,
dimct,
convert (TREE_TYPE (dimct),
size_one_node)),
build_binary_op (NE_EXPR, boolean_type_node,
build2 (BIT_AND_EXPR,
TREE_TYPE (aflags),
aflags, u),
u));
/* There is already a template in the descriptor and it is located
in block 3. The fields are 64bits so they must be repacked. */
t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN
(t)))));
lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
t = DECL_CHAIN (t);
ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
ufield = convert
(TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield);
/* Build the template in the form of a constructor. */
vec_alloc (v, 2);
CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield);
CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (template_type)),
ufield);
template_tree = gnat_build_constructor (template_type, v);
template_tree = build3 (COND_EXPR, template_type, u,
build_call_raise (CE_Length_Check_Failed, Empty,
N_Raise_Constraint_Error),
template_tree);
template_addr
= build_unary_op (ADDR_EXPR, p_bounds_type, template_tree);
break;
case 10: /* Class NCA */
default:
post_error ("unsupported descriptor type for &", gnat_subprog);
template_addr = integer_zero_node;
break;
}
/* Build the fat pointer in the form of a constructor. */
vec_alloc (v, 2);
CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr64);
CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)),
template_addr);
return gnat_build_constructor (gnu_type, v);
}
else
gcc_unreachable ();
}
/* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a
regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to
which the VMS descriptor is passed. */
static tree
convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
{
tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
/* The CLASS field is the 3rd field in the descriptor. */
tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type)));
/* The POINTER field is the 4th field in the descriptor. */
tree pointer = DECL_CHAIN (klass);
/* Retrieve the value of the POINTER field. */
tree gnu_expr32
= build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
if (POINTER_TYPE_P (gnu_type))
return convert (gnu_type, gnu_expr32);
else if (TYPE_IS_FAT_POINTER_P (gnu_type))
{
tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
tree p_bounds_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
tree template_type = TREE_TYPE (p_bounds_type);
tree min_field = TYPE_FIELDS (template_type);
tree max_field = DECL_CHAIN (TYPE_FIELDS (template_type));
tree template_tree, template_addr, aflags, dimct, t, u;
/* See the head comment of build_vms_descriptor. */
int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
vec<constructor_elt, va_gc> *v;
/* Convert POINTER to the pointer-to-array type. */
gnu_expr32 = convert (p_array_type, gnu_expr32);
switch (iklass)
{
case 1: /* Class S */
case 15: /* Class SB */
/* Build {1, LENGTH} template; LENGTH is the 1st field. */
vec_alloc (v, 2);
t = TYPE_FIELDS (desc_type);
t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
CONSTRUCTOR_APPEND_ELT (v, min_field,
convert (TREE_TYPE (min_field),
integer_one_node));
CONSTRUCTOR_APPEND_ELT (v, max_field,
convert (TREE_TYPE (max_field), t));
template_tree = gnat_build_constructor (template_type, v);
template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
/* For class S, we are done. */
if (iklass == 1)
break;
/* Test that we really have a SB descriptor, like DEC Ada. */
t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
u = build_binary_op (EQ_EXPR, boolean_type_node, t, u);
/* If so, there is already a template in the descriptor and
it is located right after the POINTER field. */
t = DECL_CHAIN (pointer);
template_tree
= build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
/* Otherwise use the {1, LENGTH} template we build above. */
template_addr = build3 (COND_EXPR, p_bounds_type, u,
build_unary_op (ADDR_EXPR, p_bounds_type,
template_tree),
template_addr);
break;
case 4: /* Class A */
/* The AFLAGS field is the 7th field in the descriptor. */
t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer)));
aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
/* The DIMCT field is the 8th field in the descriptor. */
t = DECL_CHAIN (t);
dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
/* Raise CONSTRAINT_ERROR if either more than 1 dimension
or FL_COEFF or FL_BOUNDS not set. */
u = build_int_cst (TREE_TYPE (aflags), 192);
u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node,
build_binary_op (NE_EXPR, boolean_type_node,
dimct,
convert (TREE_TYPE (dimct),
size_one_node)),
build_binary_op (NE_EXPR, boolean_type_node,
build2 (BIT_AND_EXPR,
TREE_TYPE (aflags),
aflags, u),
u));
/* There is already a template in the descriptor and it is
located at the start of block 3 (12th field). */
t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (t))));
template_tree
= build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
template_tree = build3 (COND_EXPR, TREE_TYPE (t), u,
build_call_raise (CE_Length_Check_Failed, Empty,
N_Raise_Constraint_Error),
template_tree);
template_addr
= build_unary_op (ADDR_EXPR, p_bounds_type, template_tree);
break;
case 10: /* Class NCA */
default:
post_error ("unsupported descriptor type for &", gnat_subprog);
template_addr = integer_zero_node;
break;
}
/* Build the fat pointer in the form of a constructor. */
vec_alloc (v, 2);
CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr32);
CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)),
template_addr);
return gnat_build_constructor (gnu_type, v);
}
else
gcc_unreachable ();
}
/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit)
pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the
descriptor is passed. */
tree
convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type,
Entity_Id gnat_subprog)
{
tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
tree mbo = TYPE_FIELDS (desc_type);
const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo));
tree mbmo = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (mbo)));
tree is64bit, gnu_expr32, gnu_expr64;
/* If the field name is not MBO, it must be 32-bit and no alternate.
Otherwise primary must be 64-bit and alternate 32-bit. */
if (strcmp (mbostr, "MBO") != 0)
{
tree ret = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog);
return ret;
}
/* Build the test for 64-bit descriptor. */
mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE);
mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE);
is64bit
= build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
build_binary_op (EQ_EXPR, boolean_type_node,
convert (integer_type_node, mbo),
integer_one_node),
build_binary_op (EQ_EXPR, boolean_type_node,
convert (integer_type_node, mbmo),
integer_minus_one_node));
/* Build the 2 possible end results. */
gnu_expr64 = convert_vms_descriptor64 (gnu_type, gnu_expr, gnat_subprog);
gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr);
gnu_expr32 = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog);
return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32);
}
/* Build a type to be used to represent an aliased object whose nominal type
is an unconstrained array. This consists of a RECORD_TYPE containing a
field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE.
......@@ -4704,9 +3747,9 @@ convert (tree type, tree expr)
/* If the input is a biased type, adjust first. */
if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype),
fold_convert (TREE_TYPE (etype), expr),
fold_convert (TREE_TYPE (etype),
expr),
TYPE_MIN_VALUE (etype)));
TYPE_MIN_VALUE (etype))));
/* If the input is a justified modular type, we need to extract the actual
object before converting it to any other type with the exceptions of an
......@@ -5012,7 +4055,8 @@ convert (tree type, tree expr)
return fold_convert (type,
fold_build2 (MINUS_EXPR, TREE_TYPE (type),
convert (TREE_TYPE (type), expr),
TYPE_MIN_VALUE (type)));
convert (TREE_TYPE (type),
TYPE_MIN_VALUE (type))));
/* ... fall through ... */
......@@ -5426,12 +4470,10 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
/* If both types types are integral just do a normal conversion.
Likewise for a conversion to an unconstrained array. */
if ((((INTEGRAL_TYPE_P (type)
&& !(code == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (type)))
if (((INTEGRAL_TYPE_P (type)
|| (POINTER_TYPE_P (type) && !TYPE_IS_THIN_POINTER_P (type))
|| (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type)))
&& ((INTEGRAL_TYPE_P (etype)
&& !(ecode == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (etype)))
&& (INTEGRAL_TYPE_P (etype)
|| (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype))
|| (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))))
|| code == UNCONSTRAINED_ARRAY_TYPE)
......
gcc/ada/gcc-interface/utils2.c
......@@ -300,10 +300,14 @@ compare_arrays (location_t loc, tree result_type, tree a1, tree a2)
last < first holds. */
if (integer_zerop (length2))
{
tree b = get_base_type (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
length_zero_p = true;
ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
ub1
= convert (b, TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))));
lb1
= convert (b, TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))));
comparison = fold_build2_loc (loc, LT_EXPR, result_type, ub1, lb1);
comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
......@@ -319,20 +323,23 @@ compare_arrays (location_t loc, tree result_type, tree a1, tree a2)
just use its length computed from the actual stored bounds. */
else if (TREE_CODE (length2) == INTEGER_CST)
{
tree bt;
tree b = get_base_type (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
ub1
= convert (b, TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))));
lb1
= convert (b, TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))));
/* Note that we know that UB2 and LB2 are constant and hence
cannot contain a PLACEHOLDER_EXPR. */
ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
bt = get_base_type (TREE_TYPE (ub1));
ub2
= convert (b, TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))));
lb2
= convert (b, TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))));
comparison
= fold_build2_loc (loc, EQ_EXPR, result_type,
build_binary_op (MINUS_EXPR, bt, ub1, lb1),
build_binary_op (MINUS_EXPR, bt, ub2, lb2));
build_binary_op (MINUS_EXPR, b, ub1, lb1),
build_binary_op (MINUS_EXPR, b, ub2, lb2));
comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
if (EXPR_P (comparison))
SET_EXPR_LOCATION (comparison, loc);
......@@ -2152,18 +2159,7 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
tree size_to_malloc
= aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
tree malloc_ptr;
/* On VMS, if pointers are 64-bit and the allocator size is 32-bit or
Convention C, allocate 32-bit memory. */
if (TARGET_ABI_OPEN_VMS
&& POINTER_SIZE == 64
&& Nkind (gnat_node) == N_Allocator
&& (UI_To_Int (Esize (Etype (gnat_node))) == 32
|| Convention (Etype (gnat_node)) == Convention_C))
malloc_ptr = build_call_n_expr (malloc32_decl, 1, size_to_malloc);
else
malloc_ptr = build_call_n_expr (malloc_decl, 1, size_to_malloc);
tree malloc_ptr = build_call_n_expr (malloc_decl, 1, size_to_malloc);
if (aligning_type)
{
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment