+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
|| 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). */
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))
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))
#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) \
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))
#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. */
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. */
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:
&& 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
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),
- gnat_entity, get_identifier ("L"),
- definition, true,
- Needs_Debug_Info (gnat_entity))));
+ (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
+ gnat_entity, get_identifier ("L"),
+ definition, true,
+ Needs_Debug_Info (gnat_entity)));
SET_TYPE_RM_MAX_VALUE
- (gnu_type,
- convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_High_Bound (gnat_entity),
- gnat_entity, get_identifier ("U"),
- definition, true,
- Needs_Debug_Info (gnat_entity))));
+ (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
+ gnat_entity, get_identifier ("U"),
+ definition, true,
+ Needs_Debug_Info (gnat_entity)));
TYPE_BIASED_REPRESENTATION_P (gnu_type)
= Has_Biased_Representation (gnat_entity);
= 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:
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);
}
layout_type (gnu_type);
SET_TYPE_RM_MIN_VALUE
- (gnu_type,
- convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_Low_Bound (gnat_entity),
- gnat_entity, get_identifier ("L"),
- definition, true,
- Needs_Debug_Info (gnat_entity))));
+ (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
+ gnat_entity, get_identifier ("L"),
+ definition, true,
+ Needs_Debug_Info (gnat_entity)));
SET_TYPE_RM_MAX_VALUE
- (gnu_type,
- convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_High_Bound (gnat_entity),
- gnat_entity, get_identifier ("U"),
- definition, true,
- Needs_Debug_Info (gnat_entity))));
+ (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
+ gnat_entity, get_identifier ("U"),
+ definition, true,
+ Needs_Debug_Info (gnat_entity)));
/* Inherit our alias set from what we're a subtype of, as for
integer subtypes. */
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
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
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
/* 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
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
/* 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
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,
- ©_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));
/* 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)
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
| (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
}
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;
{
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);
&& 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. */
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))
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)
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;
}
TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_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);
+}
\f
/* 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
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,
#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]
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.
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);
}
#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)
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;
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);
{
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;
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
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,
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,
}
/* 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
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
return gnu_result;
}
\f
+/* 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. */
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;
}
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));
- }
+
+ gnu_result
+ = 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
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
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. */
return gnu_result;
}
\f
-/* 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
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);
-}
\f
/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
don't return anything. */
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
}
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);
}
\f
/* Return true if GNAT_NODE requires atomic synchronization. */
const bool is_true_formal_parm
= gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
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));
+ = is_true_formal_parm
+ && (DECL_BY_REF_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
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
{
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
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 ();
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);
|| 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 ();
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);
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));
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);
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;
}
case is_required:
if (Back_End_Inlining)
- decl_attributes (&subprog_decl,
- tree_cons (get_identifier ("always_inline"),
- NULL_TREE, NULL_TREE),
- ATTR_FLAG_TYPE_IN_PLACE);
+ decl_attributes (&subprog_decl,
+ tree_cons (get_identifier ("always_inline"),
+ NULL_TREE, NULL_TREE),
+ ATTR_FLAG_TYPE_IN_PLACE);
+
/* ... fall through ... */
case is_enabled:
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;
return vector_type;
}
\f
-/* 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);
-}
-\f
/* 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.
/* 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
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 ... */
/* 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)
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);
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);
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)
{
projects / platform / upstream / linaro-gcc.git / commitdiff