* *
* C Implementation File *
* *
- * Copyright (C) 1992-2012, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2013, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
#include "gimple.h"
#include "bitmap.h"
#include "cgraph.h"
+#include "target.h"
+#include "common/common-target.h"
#include "ada.h"
#include "adadecode.h"
/* Current filename without path. */
const char *ref_filename;
+
+/* List of N_Validate_Unchecked_Conversion nodes in the unit. */
+static vec<Node_Id> gnat_validate_uc_list;
+
/* When not optimizing, we cache the 'First, 'Last and 'Length attributes
of unconstrained array IN parameters to avoid emitting a great deal of
redundant instructions to recompute them each time. */
typedef struct parm_attr_d *parm_attr;
-DEF_VEC_P(parm_attr);
-DEF_VEC_ALLOC_P(parm_attr,gc);
struct GTY(()) language_function {
- VEC(parm_attr,gc) *parm_attr_cache;
+ vec<parm_attr, va_gc> *parm_attr_cache;
bitmap named_ret_val;
- VEC(tree,gc) *other_ret_val;
+ vec<tree, va_gc> *other_ret_val;
int gnat_ret;
};
/* Stack of exception pointer variables. Each entry is the VAR_DECL
that stores the address of the raised exception. Nonzero means we
are in an exception handler. Not used in the zero-cost case. */
-static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack;
+static GTY(()) vec<tree, va_gc> *gnu_except_ptr_stack;
/* In ZCX case, current exception pointer. Used to re-raise it. */
static GTY(()) tree gnu_incoming_exc_ptr;
/* Stack for storing the current elaboration procedure decl. */
-static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack;
+static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack;
/* Stack of labels to be used as a goto target instead of a return in
some functions. See processing for N_Subprogram_Body. */
-static GTY(()) VEC(tree,gc) *gnu_return_label_stack;
+static GTY(()) vec<tree, va_gc> *gnu_return_label_stack;
/* Stack of variable for the return value of a function with copy-in/copy-out
parameters. See processing for N_Subprogram_Body. */
-static GTY(()) VEC(tree,gc) *gnu_return_var_stack;
+static GTY(()) vec<tree, va_gc> *gnu_return_var_stack;
/* Structure used to record information for a range check. */
struct GTY(()) range_check_info_d {
typedef struct range_check_info_d *range_check_info;
-DEF_VEC_P(range_check_info);
-DEF_VEC_ALLOC_P(range_check_info,gc);
/* Structure used to record information for a loop. */
struct GTY(()) loop_info_d {
tree label;
tree loop_var;
- VEC(range_check_info,gc) *checks;
+ vec<range_check_info, va_gc> *checks;
};
typedef struct loop_info_d *loop_info;
-DEF_VEC_P(loop_info);
-DEF_VEC_ALLOC_P(loop_info,gc);
/* Stack of loop_info structures associated with LOOP_STMT nodes. */
-static GTY(()) VEC(loop_info,gc) *gnu_loop_stack;
+static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
/* The stacks for N_{Push,Pop}_*_Label. */
-static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack;
-static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack;
-static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack;
+static GTY(()) vec<tree, va_gc> *gnu_constraint_error_label_stack;
+static GTY(()) vec<tree, va_gc> *gnu_storage_error_label_stack;
+static GTY(()) vec<tree, va_gc> *gnu_program_error_label_stack;
/* Map GNAT tree codes to GCC tree codes for simple expressions. */
static enum tree_code gnu_codes[Number_Node_Kinds];
static void insert_code_for (Node_Id);
static void add_cleanup (tree, Node_Id);
static void add_stmt_list (List_Id);
-static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id);
+static void push_exception_label_stack (vec<tree, va_gc> **, Entity_Id);
static tree build_stmt_group (List_Id, bool);
+static inline bool stmt_group_may_fallthru (void);
static enum gimplify_status gnat_gimplify_stmt (tree *);
static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
static tree extract_values (tree, tree);
static tree pos_to_constructor (Node_Id, tree, Entity_Id);
+static void validate_unchecked_conversion (Node_Id);
static tree maybe_implicit_deref (tree);
static void set_expr_location_from_node (tree, Node_Id);
static bool set_end_locus_from_node (tree, Node_Id);
Entity_Id standard_character, Entity_Id standard_long_long_float,
Entity_Id standard_exception_type, Int gigi_operating_mode)
{
+ 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);
struct elab_info *info;
int i;
+#ifdef ORDINARY_MAP_INSTANCE
+ struct line_map *map;
+#endif
max_gnat_nodes = max_gnat_node;
type_annotate_only = (gigi_operating_mode == 1);
+ /* ??? Disable the generation of the SCO instance table until after the
+ back-end supports instance based debug info discriminators. */
+ Generate_SCO_Instance_Table = False;
+
for (i = 0; i < number_file; i++)
{
/* Use the identifier table to make a permanent copy of the filename as
/* We create the line map for a source file at once, with a fixed number
of columns chosen to avoid jumping over the next power of 2. */
linemap_add (line_table, LC_ENTER, 0, filename, 1);
+#ifdef ORDINARY_MAP_INSTANCE
+ map = LINEMAPS_ORDINARY_MAP_AT (line_table, i);
+ if (flag_debug_instances)
+ ORDINARY_MAP_INSTANCE (map) = file_info_ptr[i].Instance;
+#endif
linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
linemap_position_for_column (line_table, 252 - 1);
linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
/* Initialize ourselves. */
init_code_table ();
- init_gnat_to_gnu ();
- init_dummy_type ();
+ init_gnat_utils ();
/* If we are just annotating types, give VOID_TYPE zero sizes to avoid
errors. */
Empty);
DECL_IGNORED_P (end_handler_decl) = 1;
+ unhandled_except_decl
+ = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
+ NULL_TREE,
+ ftype, NULL_TREE, false, true, true, true, NULL,
+ Empty);
+ DECL_IGNORED_P (unhandled_except_decl) = 1;
+
reraise_zcx_decl
= create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
ftype, NULL_TREE, false, true, true, true, NULL,
Empty);
+ /* Indicate that these never return. */
DECL_IGNORED_P (reraise_zcx_decl) = 1;
+ TREE_THIS_VOLATILE (reraise_zcx_decl) = 1;
+ TREE_SIDE_EFFECTS (reraise_zcx_decl) = 1;
+ TREE_TYPE (reraise_zcx_decl)
+ = build_qualified_type (TREE_TYPE (reraise_zcx_decl), TYPE_QUAL_VOLATILE);
/* If in no exception handlers mode, all raise statements are redirected to
__gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
build_function_type_list (build_pointer_type (except_type_node),
NULL_TREE),
NULL_TREE, false, true, true, true, NULL, Empty);
+ DECL_IGNORED_P (get_excptr_decl) = 1;
raise_nodefer_decl
= create_subprog_decl
tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
tree field_list = NULL_TREE;
int j;
- VEC(constructor_elt,gc) *null_vec = NULL;
+ vec<constructor_elt, va_gc> *null_vec = NULL;
constructor_elt *elt;
fdesc_type_node = make_node (RECORD_TYPE);
- VEC_safe_grow (constructor_elt, gc, null_vec,
- TARGET_VTABLE_USES_DESCRIPTORS);
- elt = (VEC_address (constructor_elt,null_vec)
- + TARGET_VTABLE_USES_DESCRIPTORS - 1);
+ vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS);
+ elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
{
integer_type_node, NULL_TREE, true, false, true, false,
NULL, Empty);
+ unhandled_others_decl
+ = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
+ get_identifier ("__gnat_unhandled_others_value"),
+ integer_type_node, NULL_TREE, true, false, true, false,
+ NULL, Empty);
+
main_identifier_node = get_identifier ("main");
/* Install the builtins we might need, either internally or as
user available facilities for Intrinsic imports. */
gnat_install_builtins ();
- VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE);
- VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE);
- VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE);
- VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE);
+ vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
+ vec_safe_push (gnu_constraint_error_label_stack, NULL_TREE);
+ vec_safe_push (gnu_storage_error_label_stack, NULL_TREE);
+ vec_safe_push (gnu_program_error_label_stack, NULL_TREE);
/* Process any Pragma Ident for the main unit. */
-#ifdef ASM_OUTPUT_IDENT
if (Present (Ident_String (Main_Unit)))
- ASM_OUTPUT_IDENT
- (asm_out_file,
- TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
-#endif
+ targetm.asm_out.output_ident
+ (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
/* If we are using the GCC exception mechanism, let GCC know. */
if (Exception_Mechanism == Back_End_Exceptions)
/* Now translate the compilation unit proper. */
Compilation_Unit_to_gnu (gnat_root);
+ /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
+ the very end to avoid having to second-guess the front-end when we run
+ into dummy nodes during the regular processing. */
+ for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++)
+ validate_unchecked_conversion (gnat_iter);
+ gnat_validate_uc_list.release ();
+
/* Finally see if we have any elaboration procedures to deal with. */
for (info = elab_info_list; info; info = info->next)
{
}
}
+ /* Destroy ourselves. */
+ destroy_gnat_utils ();
+
/* We cannot track the location of errors past this point. */
error_gnat_node = Empty;
}
static tree
build_raise_check (int check, enum exception_info_kind kind)
{
- char name[21];
tree result, ftype;
+ const char pfx[] = "__gnat_rcheck_";
+
+ strcpy (Name_Buffer, pfx);
+ Name_Len = sizeof (pfx) - 1;
+ Get_RT_Exception_Name (check);
if (kind == exception_simple)
{
- sprintf (name, "__gnat_rcheck_%.2d", check);
+ Name_Buffer[Name_Len] = 0;
ftype
= build_function_type_list (void_type_node,
build_pointer_type
else
{
tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
- sprintf (name, "__gnat_rcheck_%.2d_ext", check);
+
+ strcpy (Name_Buffer + Name_Len, "_ext");
+ Name_Buffer[Name_Len + 4] = 0;
ftype
= build_function_type_list (void_type_node,
build_pointer_type
}
result
- = create_subprog_decl (get_identifier (name), NULL_TREE, ftype, NULL_TREE,
+ = create_subprog_decl (get_identifier (Name_Buffer),
+ NULL_TREE, ftype, NULL_TREE,
false, true, true, true, NULL, Empty);
/* Indicate that it never returns. */
order-of-elaboration issue here. */
gnu_result_type = get_unpadded_type (gnat_temp_type);
- /* If this is a non-imported scalar constant with an address clause,
+ /* If this is a non-imported elementary constant with an address clause,
retrieve the value instead of a pointer to be dereferenced unless
an lvalue is required. This is generally more efficient and actually
required if this is a static expression because it might be used
volatile-ness short-circuit here since Volatile constants must be
imported per C.6. */
if (Ekind (gnat_temp) == E_Constant
- && Is_Scalar_Type (gnat_temp_type)
+ && Is_Elementary_Type (gnat_temp_type)
&& !Is_Imported (gnat_temp)
&& Present (Address_Clause (gnat_temp)))
{
= convert (build_pointer_type (gnu_result_type), gnu_result);
/* If it's a CONST_DECL, return the underlying constant like below. */
- else if (TREE_CODE (gnu_result) == CONST_DECL)
+ else if (TREE_CODE (gnu_result) == CONST_DECL
+ && !(DECL_CONST_ADDRESS_P (gnu_result)
+ && lvalue_required_p (gnat_node, gnu_result_type, true,
+ true, false)))
gnu_result = DECL_INITIAL (gnu_result);
/* If it's a renaming pointer and we are at the right binding level,
= lvalue_required_p (gnat_node, gnu_result_type, true,
address_of_constant, Is_Aliased (gnat_temp));
- /* ??? We need to unshare the initializer if the object is external
- as such objects are not marked for unsharing if we are not at the
- global level. This should be fixed in add_decl_expr. */
+ /* Finally retrieve the initializer if this is deemed valid. */
if ((constant_only && !address_of_constant) || !require_lvalue)
- gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
+ gnu_result = DECL_INITIAL (gnu_result);
}
/* The GNAT tree has the type of a function set to its result type, so we
switch (Chars (Expression
(First (Pragma_Argument_Associations (gnat_node)))))
{
- case Name_Time: case Name_Space:
- if (!optimize)
- post_error ("insufficient -O value?", gnat_node);
- break;
-
case Name_Off:
if (optimize)
post_error ("must specify -O0?", gnat_node);
break;
+ case Name_Space:
+ if (!optimize_size)
+ post_error ("must specify -Os?", gnat_node);
+ break;
+
+ case Name_Time:
+ if (!optimize)
+ post_error ("insufficient -O value?", gnat_node);
+ break;
+
default:
gcc_unreachable ();
}
/* Descriptors can only be built here for top-level functions. */
bool build_descriptor = (global_bindings_p () != 0);
int i;
- VEC(constructor_elt,gc) *gnu_vec = NULL;
+ vec<constructor_elt, va_gc> *gnu_vec = NULL;
constructor_elt *elt;
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
}
- VEC_safe_grow (constructor_elt, gc, gnu_vec,
- TARGET_VTABLE_USES_DESCRIPTORS);
- elt = (VEC_address (constructor_elt, gnu_vec)
- + TARGET_VTABLE_USES_DESCRIPTORS - 1);
+ vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS);
+ elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
i < TARGET_VTABLE_USES_DESCRIPTORS;
gnu_field = DECL_CHAIN (gnu_field), i++)
case Attr_Pool_Address:
{
- tree gnu_obj_type;
tree gnu_ptr = gnu_prefix;
+ tree gnu_obj_type;
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- /* If this is an unconstrained array, we know the object has been
- allocated with the template in front of the object. So compute
- the template address. */
+ /* If this is fat pointer, the object must have been allocated with the
+ template in front of the array. So compute the template address; do
+ it by converting to a thin pointer. */
if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr
= convert (build_pointer_type
gnu_ptr);
gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
- if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
- {
- tree gnu_char_ptr_type
- = build_pointer_type (unsigned_char_type_node);
- tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
- gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
- gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
- gnu_ptr, gnu_pos);
- }
+
+ /* If this is a thin pointer, the object must have been allocated with
+ the template in front of the array. So compute the template address
+ and return it. */
+ if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
+ gnu_ptr
+ = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
+ gnu_ptr,
+ fold_build1 (NEGATE_EXPR, sizetype,
+ byte_position
+ (DECL_CHAIN
+ TYPE_FIELDS ((gnu_obj_type)))));
gnu_result = convert (gnu_result_type, gnu_ptr);
}
gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
}
- /* If we're looking for the size of a field, return the field size.
- Otherwise, if the prefix is an object, or if we're looking for
- 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
- GCC size of the type. Otherwise, it is the RM size of the type. */
+ /* If we're looking for the size of a field, return the field size. */
if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
- else if (TREE_CODE (gnu_prefix) != TYPE_DECL
+
+ /* Otherwise, if the prefix is an object, or if we are looking for
+ 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
+ GCC size of the type. We make an exception for padded objects,
+ as we do not take into account alignment promotions for the size.
+ This is in keeping with the object case of gnat_to_gnu_entity. */
+ else if ((TREE_CODE (gnu_prefix) != TYPE_DECL
+ && !(TYPE_IS_PADDING_P (gnu_type)
+ && TREE_CODE (gnu_expr) == COMPONENT_REF))
|| attribute == Attr_Object_Size
|| attribute == Attr_Max_Size_In_Storage_Elements)
{
- /* If the prefix is an object of a padded type, the GCC size isn't
- relevant to the programmer. Normally what we want is the RM size,
- which was set from the specified size, but if it was not set, we
- want the size of the field. Using the MAX of those two produces
- the right result in all cases. Don't use the size of the field
- if it's self-referential, since that's never what's wanted. */
- if (TREE_CODE (gnu_prefix) != TYPE_DECL
- && TYPE_IS_PADDING_P (gnu_type)
- && TREE_CODE (gnu_expr) == COMPONENT_REF)
- {
- gnu_result = rm_size (gnu_type);
- if (!CONTAINS_PLACEHOLDER_P
- (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
- gnu_result
- = size_binop (MAX_EXPR, gnu_result,
- DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
- }
- else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
+ /* If this is a dereference and we have a special dynamic constrained
+ subtype on the prefix, use it to compute the size; otherwise, use
+ the designated subtype. */
+ if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
{
Node_Id gnat_deref = Prefix (gnat_node);
Node_Id gnat_actual_subtype
get_identifier ("SIZE"),
false);
}
-
- gnu_result = TYPE_SIZE (gnu_type);
}
- else
- gnu_result = TYPE_SIZE (gnu_type);
+
+ gnu_result = TYPE_SIZE (gnu_type);
}
+
+ /* Otherwise, the result is the RM size of the type. */
else
gnu_result = rm_size (gnu_type);
gnat_param = Entity (Prefix (gnat_prefix));
}
- gnu_type = TREE_TYPE (gnu_prefix);
+ /* If the prefix is the view conversion of a constrained array to an
+ unconstrained form, we retrieve the constrained array because we
+ might not be able to substitute the PLACEHOLDER_EXPR coming from
+ the conversion. This can occur with the 'Old attribute applied
+ to a parameter with an unconstrained type, which gets rewritten
+ into a constrained local variable very late in the game. */
+ if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix)))
+ && !CONTAINS_PLACEHOLDER_P
+ (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
+ gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0));
+ else
+ gnu_type = TREE_TYPE (gnu_prefix);
+
prefix_unused = true;
gnu_result_type = get_unpadded_type (Etype (gnat_node));
and the dimension in the cache and create a new one on failure. */
if (!optimize && Present (gnat_param))
{
- FOR_EACH_VEC_ELT (parm_attr, f_parm_attr_cache, i, pa)
+ FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa)
if (pa->id == gnat_param && pa->dim == Dimension)
break;
pa = ggc_alloc_cleared_parm_attr_d ();
pa->id = gnat_param;
pa->dim = Dimension;
- VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
+ vec_safe_push (f_parm_attr_cache, pa);
}
}
gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
gnu_result = size_binop (PLUS_EXPR, gnu_result,
TYPE_SIZE (TREE_TYPE (gnu_prefix)));
- gnu_result = size_binop (MINUS_EXPR, gnu_result,
- bitsize_one_node);
+ /* ??? Avoid a large unsigned result that will overflow when
+ converted to the signed universal_integer. */
+ if (integer_zerop (gnu_result))
+ gnu_result = integer_minus_one_node;
+ else
+ gnu_result
+ = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node);
break;
case Attr_Bit_Position:
gnu_result = gnu_field_bitpos;
break;
- }
+ }
/* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
handling. */
gnu_type = TREE_TYPE (gnu_prefix);
gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
- /* What we want is the offset of the ARRAY field in the record that the
- thin pointer designates, but the components have been shifted so this
- is actually the opposite of the offset of the BOUNDS field. */
+ /* What we want is the offset of the ARRAY field in the record
+ that the thin pointer designates. */
gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
- gnu_result = size_binop (MINUS_EXPR, bitsize_zero_node,
- bit_position (TYPE_FIELDS (gnu_type)));
+ gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
prefix_unused = true;
break;
break;
default:
- /* Say we have an unimplemented attribute. Then set the value to be
- returned to be a zero and hope that's something we can convert to
- the type of this attribute. */
- post_error ("unimplemented attribute", gnat_node);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = integer_zero_node;
- break;
+ /* This abort means that we have an unimplemented attribute. */
+ gcc_unreachable ();
}
/* If this is an attribute where the prefix was unused, force a use of it if
struct loop_info_d *iter = NULL;
unsigned int i;
- if (VEC_empty (loop_info, gnu_loop_stack))
+ if (vec_safe_is_empty (gnu_loop_stack))
return NULL;
var = remove_conversions (var, false);
if (decl_function_context (var) != current_function_decl)
return NULL;
- for (i = VEC_length (loop_info, gnu_loop_stack) - 1;
- VEC_iterate (loop_info, gnu_loop_stack, i, iter);
+ for (i = vec_safe_length (gnu_loop_stack) - 1;
+ vec_safe_iterate (gnu_loop_stack, i, &iter);
i--)
if (var == iter->loop_var)
break;
if (iter)
{
struct range_check_info_d *rci = ggc_alloc_range_check_info_d ();
- VEC_safe_push (range_check_info, gc, iter->checks, rci);
+ vec_safe_push (iter->checks, rci);
return rci;
}
tree gnu_result;
/* Push the loop_info structure associated with the LOOP_STMT. */
- VEC_safe_push (loop_info, gc, gnu_loop_stack, gnu_loop_info);
+ vec_safe_push (gnu_loop_stack, gnu_loop_info);
/* Set location information for statement and end label. */
set_expr_location_from_node (gnu_loop_stmt, gnat_node);
if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
{
struct range_check_info_d *rci;
- unsigned n_checks = VEC_length (range_check_info, gnu_loop_info->checks);
+ unsigned n_checks = vec_safe_length (gnu_loop_info->checks);
unsigned int i;
/* First, if we have computed a small number of invariant conditions for
that can be entirely optimized away in the end. */
if (1 <= n_checks && n_checks <= 4)
for (i = 0;
- VEC_iterate (range_check_info, gnu_loop_info->checks, i, rci);
+ vec_safe_iterate (gnu_loop_info->checks, i, &rci);
i++)
{
tree low_ok
- = build_binary_op (GE_EXPR, boolean_type_node,
- convert (rci->type, gnu_low),
- rci->low_bound);
+ = rci->low_bound
+ ? build_binary_op (GE_EXPR, boolean_type_node,
+ convert (rci->type, gnu_low),
+ rci->low_bound)
+ : boolean_true_node;
+
tree high_ok
- = build_binary_op (LE_EXPR, boolean_type_node,
- convert (rci->type, gnu_high),
- rci->high_bound);
+ = rci->high_bound
+ ? build_binary_op (LE_EXPR, boolean_type_node,
+ convert (rci->type, gnu_high),
+ rci->high_bound)
+ : boolean_true_node;
+
tree range_ok
= build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
low_ok, high_ok);
else
gnu_result = gnu_loop_stmt;
- VEC_pop (loop_info, gnu_loop_stack);
+ gnu_loop_stack->pop ();
return gnu_result;
}
tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1), init_expr;
/* If this is the temporary created for a return value with variable
- size in call_to_gnu, we replace the RHS with the init expression. */
+ size in Call_to_gnu, we replace the RHS with the init expression. */
if (TREE_CODE (ret_val) == COMPOUND_EXPR
&& TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
&& TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
{
if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
ret_val
- = VEC_index (constructor_elt,
- CONSTRUCTOR_ELTS
- (TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1)),
- 1)->value;
+ = (*CONSTRUCTOR_ELTS (TREE_OPERAND (TREE_OPERAND (ret_val, 0),
+ 1)))[1].value;
else
ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
}
tree saved_current_function_decl = current_function_decl;
tree var = DECL_EXPR_DECL (t);
tree alloc, p_array, new_var, new_ret;
- VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
+ vec<constructor_elt, va_gc> *v;
+ vec_alloc (v, 2);
/* Create an artificial context to build the allocation. */
current_function_decl = decl_function_context (var);
DECL_INITIAL (new_var)
= build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
TREE_OPERAND (alloc, 0),
- VEC_index (constructor_elt,
- CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)),
- 0)->value);
+ (*CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)))[0].value);
/* Build a modified CONSTRUCTOR that references NEW_VAR. */
p_array = TYPE_FIELDS (TREE_TYPE (alloc));
CONSTRUCTOR_APPEND_ELT (v, p_array,
fold_convert (TREE_TYPE (p_array), new_var));
CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
- VEC_index (constructor_elt,
- CONSTRUCTOR_ELTS
- (TREE_OPERAND (alloc, 1)),
- 1)->value);
+ (*CONSTRUCTOR_ELTS (
+ TREE_OPERAND (alloc, 1)))[1].value);
new_ret = build_constructor (TREE_TYPE (alloc), v);
}
else
the other return values. GNAT_RET is a representative return node. */
static void
-finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other, Node_Id gnat_ret)
+finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret)
{
struct cgraph_node *node;
struct nrv_data data;
data.nrv = nrv;
data.result = NULL_TREE;
data.visited = NULL;
- for (i = 0; VEC_iterate(tree, other, i, iter); i++)
+ for (i = 0; vec_safe_iterate (other, i, &iter); i++)
walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
if (bitmap_empty_p (nrv))
return;
/* Prune also the candidates that are referenced by nested functions. */
node = cgraph_get_create_node (fndecl);
for (node = node->nested; node; node = node->next_nested)
- walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r,
+ walk_tree_without_duplicates (&DECL_SAVED_TREE (node->symbol.decl), prune_nrv_r,
&data);
if (bitmap_empty_p (nrv))
return;
&& aggregate_value_p (operation_type, current_function_decl))
{
/* Recognize the temporary created for a return value with variable
- size in call_to_gnu. We want to eliminate it if possible. */
+ size in Call_to_gnu. We want to eliminate it if possible. */
if (TREE_CODE (ret_val) == COMPOUND_EXPR
&& TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
&& TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
totally transparent given the read-compose-write semantics of
assignments from CONSTRUCTORs. */
else if (EXPR_P (ret_val))
- VEC_safe_push (tree, gc, f_other_ret_val, ret_val);
+ vec_safe_push (f_other_ret_val, ret_val);
}
}
else
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,gc) *gnu_param_vec = NULL;
+ vec<tree, va_gc> *gnu_param_vec = NULL;
gnu_subprog_type = TREE_TYPE (gnu_subprog);
else
gnu_param = gnu_stub_param;
- VEC_safe_push (tree, gc, gnu_param_vec, gnu_param);
+ vec_safe_push (gnu_param_vec, gnu_param);
}
/* Invoke the internal subprogram. */
tree gnu_return_var_elmt = NULL_TREE;
tree gnu_result;
struct language_function *gnu_subprog_language;
- VEC(parm_attr,gc) *cache;
+ vec<parm_attr, va_gc> *cache;
/* If this is a generic object or if it has been eliminated,
ignore it. */
{
tree gnu_return_var = NULL_TREE;
- VEC_safe_push (tree, gc, gnu_return_label_stack,
+ vec_safe_push (gnu_return_label_stack,
create_artificial_label (input_location));
start_stmt_group ();
TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
}
- VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var);
+ vec_safe_push (gnu_return_var_stack, gnu_return_var);
/* See whether there are parameters for which we don't have a GCC tree
yet. These must be Out parameters. Make a VAR_DECL for them and
if (!present_gnu_tree (gnat_param))
{
tree gnu_cico_entry = gnu_cico_list;
+ tree gnu_decl;
/* Skip any entries that have been already filled in; they must
correspond to In Out parameters. */
while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
+ /* Do any needed dereferences for by-ref objects. */
+ gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, 1);
+ gcc_assert (DECL_P (gnu_decl));
+ if (DECL_BY_REF_P (gnu_decl))
+ gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
+
/* Do any needed references for padded types. */
TREE_VALUE (gnu_cico_entry)
- = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)),
- gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
+ = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl);
}
}
else
- VEC_safe_push (tree, gc, gnu_return_label_stack, NULL_TREE);
+ vec_safe_push (gnu_return_label_stack, NULL_TREE);
/* Get a tree corresponding to the code for the subprogram. */
start_stmt_group ();
start_stmt_group ();
- FOR_EACH_VEC_ELT (parm_attr, cache, i, pa)
+ FOR_EACH_VEC_ELT (*cache, i, pa)
{
if (pa->first)
add_stmt_with_node_force (pa->first, gnat_node);
add_stmt (gnu_result);
add_stmt (build1 (LABEL_EXPR, void_type_node,
- VEC_last (tree, gnu_return_label_stack)));
+ gnu_return_label_stack->last ()));
if (list_length (gnu_cico_list) == 1)
gnu_retval = TREE_VALUE (gnu_cico_list);
gnu_result = end_stmt_group ();
}
- VEC_pop (tree, gnu_return_label_stack);
+ gnu_return_label_stack->pop ();
/* Attempt setting the end_locus of our GCC body tree, typically a
BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
set_end_locus_from_node (gnu_result, gnat_node);
set_end_locus_from_node (gnu_subprog_decl, gnat_node);
+ /* On SEH targets, install an exception handler around the main entry
+ point to catch unhandled exceptions. */
+ if (DECL_NAME (gnu_subprog_decl) == main_identifier_node
+ && targetm_common.except_unwind_info (&global_options) == UI_SEH)
+ {
+ tree t;
+ tree etype;
+
+ t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
+ 1, integer_zero_node);
+ t = build_call_n_expr (unhandled_except_decl, 1, t);
+
+ etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl);
+ etype = tree_cons (NULL_TREE, etype, NULL_TREE);
+
+ t = build2 (CATCH_EXPR, void_type_node, etype, t);
+ gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result),
+ gnu_result, t);
+ }
+
end_subprog_body (gnu_result);
/* Finally annotate the parameters and disconnect the trees for parameters
/* 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);
-
- mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
}
\f
/* Return true if GNAT_NODE requires atomic synchronization. */
requires atomic synchronization. */
static tree
-call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
+Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
bool atomic_sync)
{
const bool function_call = (Nkind (gnat_node) == N_Function_Call);
/* The return type of the FUNCTION_TYPE. */
tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
- VEC(tree,gc) *gnu_actual_vec = NULL;
+ vec<tree, va_gc> *gnu_actual_vec = NULL;
tree gnu_name_list = NULL_TREE;
tree gnu_stmt_list = NULL_TREE;
tree gnu_after_list = NULL_TREE;
gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
}
- VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual);
+ vec_safe_push (gnu_actual_vec, gnu_actual);
}
gnu_call
start_stmt_group ();
gnat_pushlevel ();
- VEC_safe_push (tree, gc, gnu_except_ptr_stack,
+ vec_safe_push (gnu_except_ptr_stack,
create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
build_pointer_type (except_type_node),
build_call_n_expr (get_excptr_decl, 0),
/* If none of the exception handlers did anything, re-raise but do not
defer abortion. */
gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
- VEC_last (tree, gnu_except_ptr_stack));
+ gnu_except_ptr_stack->last ());
set_expr_location_from_node
(gnu_expr,
Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
/* End the binding level dedicated to the exception handlers and get the
whole statement group. */
- VEC_pop (tree, gnu_except_ptr_stack);
+ gnu_except_ptr_stack->pop ();
gnat_poplevel ();
gnu_handler = end_stmt_group ();
else if (gcc_zcx)
{
tree gnu_handlers;
+ location_t locus;
/* First make a block containing the handlers. */
start_stmt_group ();
/* Now make the TRY_CATCH_EXPR for the block. */
gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
gnu_inner_block, gnu_handlers);
+ /* Set a location. We need to find a uniq location for the dispatching
+ code, otherwise we can get coverage or debugging issues. Try with
+ the location of the end label. */
+ if (Present (End_Label (gnat_node))
+ && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus))
+ SET_EXPR_LOCATION (gnu_result, locus);
+ else
+ set_expr_location_from_node (gnu_result, gnat_node);
}
else
gnu_result = gnu_inner_block;
build_component_ref
(build_unary_op
(INDIRECT_REF, NULL_TREE,
- VEC_last (tree, gnu_except_ptr_stack)),
+ gnu_except_ptr_stack->last ()),
get_identifier ("not_handled_by_others"), NULL_TREE,
false)),
integer_zero_node);
this_choice
= build_binary_op
(EQ_EXPR, boolean_type_node,
- VEC_last (tree, gnu_except_ptr_stack),
- convert (TREE_TYPE (VEC_last (tree, gnu_except_ptr_stack)),
+ gnu_except_ptr_stack->last (),
+ convert (TREE_TYPE (gnu_except_ptr_stack->last ()),
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
/* If this is the distinguished exception "Non_Ada_Error" (and we are
tree gnu_comp
= build_component_ref
(build_unary_op (INDIRECT_REF, NULL_TREE,
- VEC_last (tree, gnu_except_ptr_stack)),
+ gnu_except_ptr_stack->last ()),
get_identifier ("lang"), NULL_TREE, false);
this_choice
const bool body_p = (Nkind (gnat_unit) == N_Package_Body
|| Nkind (gnat_unit) == N_Subprogram_Body);
const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
+ Node_Id gnat_pragma;
/* Make the decl for the elaboration procedure. */
tree gnu_elab_proc_decl
= create_subprog_decl
gnat_unit);
struct elab_info *info;
- VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl);
+ vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
/* Initialize the information structure for the function. */
return;
}
+ /* Then process any pragmas and declarations preceding the unit. */
+ for (gnat_pragma = First (Context_Items (gnat_node));
+ Present (gnat_pragma);
+ gnat_pragma = Next (gnat_pragma))
+ if (Nkind (gnat_pragma) == N_Pragma)
+ add_stmt (gnat_to_gnu (gnat_pragma));
process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
true, true);
+
+ /* Process the unit itself. */
add_stmt (gnat_to_gnu (gnat_unit));
/* If we can inline, generate code for all the inlined subprograms. */
/* Generate elaboration code for this unit, if necessary, and say whether
we did or not. */
- VEC_pop (tree, gnu_elab_proc_stack);
+ gnu_elab_proc_stack->pop ();
/* Invalidate the global renaming pointers. This is necessary because
stabilization of the renamed entities may create SAVE_EXPRs which
invalidate_global_renaming_pointers ();
}
\f
+/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Raise_xxx_Error,
+ to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where
+ we should place the result type. LABEL_P is true if there is a label to
+ branch to for the exception. */
+
+static tree
+Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
+{
+ const Node_Kind kind = Nkind (gnat_node);
+ const int reason = UI_To_Int (Reason (gnat_node));
+ const Node_Id gnat_cond = Condition (gnat_node);
+ const bool with_extra_info
+ = Exception_Extra_Info
+ && !No_Exception_Handlers_Set ()
+ && !get_exception_label (kind);
+ tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
+
+ *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
+
+ switch (reason)
+ {
+ case CE_Access_Check_Failed:
+ if (with_extra_info)
+ gnu_result = build_call_raise_column (reason, gnat_node);
+ break;
+
+ case CE_Index_Check_Failed:
+ case CE_Range_Check_Failed:
+ case CE_Invalid_Data:
+ if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
+ {
+ Node_Id gnat_range, gnat_index, gnat_type;
+ tree gnu_index, gnu_low_bound, gnu_high_bound;
+ struct range_check_info_d *rci;
+
+ switch (Nkind (Right_Opnd (gnat_cond)))
+ {
+ case N_In:
+ gnat_range = Right_Opnd (Right_Opnd (gnat_cond));
+ gcc_assert (Nkind (gnat_range) == N_Range);
+ gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range));
+ gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range));
+ break;
+
+ case N_Op_Ge:
+ gnu_low_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
+ gnu_high_bound = NULL_TREE;
+ break;
+
+ case N_Op_Le:
+ gnu_low_bound = NULL_TREE;
+ gnu_high_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
+ break;
+
+ default:
+ goto common;
+ }
+
+ gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
+ gnat_type = Etype (gnat_index);
+ gnu_index = gnat_to_gnu (gnat_index);
+
+ if (with_extra_info
+ && gnu_low_bound
+ && gnu_high_bound
+ && Known_Esize (gnat_type)
+ && UI_To_Int (Esize (gnat_type)) <= 32)
+ gnu_result
+ = build_call_raise_range (reason, gnat_node, gnu_index,
+ gnu_low_bound, gnu_high_bound);
+
+ /* If loop unswitching is enabled, we try to compute invariant
+ conditions for checks applied to iteration variables, i.e.
+ conditions that are both independent of the variable and
+ necessary in order for the check to fail in the course of
+ some iteration, and prepend them to the original condition
+ of the checks. This will make it possible later for the
+ loop unswitching pass to replace the loop with two loops,
+ one of which has the checks eliminated and the other has
+ the original checks reinstated, and a run time selection.
+ The former loop will be suitable for vectorization. */
+ if (flag_unswitch_loops
+ && (!gnu_low_bound
+ || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)))
+ && (!gnu_high_bound
+ || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)))
+ && (rci = push_range_check_info (gnu_index)))
+ {
+ rci->low_bound = gnu_low_bound;
+ rci->high_bound = gnu_high_bound;
+ rci->type = get_unpadded_type (gnat_type);
+ rci->invariant_cond = build1 (SAVE_EXPR, boolean_type_node,
+ boolean_true_node);
+ gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
+ boolean_type_node,
+ rci->invariant_cond,
+ gnat_to_gnu (gnat_cond));
+ }
+ }
+ break;
+
+ default:
+ break;
+ }
+
+common:
+ if (!gnu_result)
+ gnu_result = build_call_raise (reason, gnat_node, kind);
+ set_expr_location_from_node (gnu_result, gnat_node);
+
+ /* If the type is VOID, this is a statement, so we need to generate the code
+ for the call. Handle a condition, if there is one. */
+ if (VOID_TYPE_P (*gnu_result_type_p))
+ {
+ if (Present (gnat_cond))
+ {
+ if (!gnu_cond)
+ gnu_cond = gnat_to_gnu (gnat_cond);
+ gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
+ alloc_stmt_list ());
+ }
+ }
+ else
+ gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
+
+ return gnu_result;
+}
+\f
/* Return true if GNAT_NODE is on the LHS of an assignment or an actual
parameter of a call. */
break;
case N_Real_Literal:
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
/* If this is of a fixed-point type, the value we want is the
value of the corresponding integer. */
if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
{
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
gnu_result_type);
gcc_assert (!TREE_OVERFLOW (gnu_result));
}
- /* We should never see a Vax_Float type literal, since the front end
- is supposed to transform these using appropriate conversions. */
+ /* Convert the Ureal to a vax float (represented on a signed type). */
else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
- gcc_unreachable ();
+ {
+ gnu_result = UI_To_gnu (Get_Vax_Real_Literal_As_Signed (gnat_node),
+ gnu_result_type);
+ }
else
{
Ureal ur_realval = Realval (gnat_node);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ /* First convert the real value to a machine number if it isn't
+ already. That forces BASE to 2 for non-zero values and simplifies
+ the rest of our logic. */
+
+ if (!Is_Machine_Number (gnat_node))
+ ur_realval
+ = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
+ ur_realval, Round_Even, gnat_node);
- /* If the real value is zero, so is the result. Otherwise,
- convert it to a machine number if it isn't already. That
- forces BASE to 0 or 2 and simplifies the rest of our logic. */
if (UR_Is_Zero (ur_realval))
gnu_result = convert (gnu_result_type, integer_zero_node);
else
{
- if (!Is_Machine_Number (gnat_node))
- ur_realval
- = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
- ur_realval, Round_Even, gnat_node);
+ REAL_VALUE_TYPE tmp;
gnu_result
= UI_To_gnu (Numerator (ur_realval), gnu_result_type);
- /* If we have a base of zero, divide by the denominator.
- Otherwise, the base must be 2 and we scale the value, which
- we know can fit in the mantissa of the type (hence the use
- of that type above). */
- if (No (Rbase (ur_realval)))
- gnu_result
- = build_binary_op (RDIV_EXPR,
- get_base_type (gnu_result_type),
- gnu_result,
- UI_To_gnu (Denominator (ur_realval),
- gnu_result_type));
- else
- {
- REAL_VALUE_TYPE tmp;
+ /* The base must be 2 as Machine guarantees this, so we scale
+ the value, which we know can fit in the mantissa of the type
+ (hence the use of that type above). */
- gcc_assert (Rbase (ur_realval) == 2);
- real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
- - UI_To_Int (Denominator (ur_realval)));
- gnu_result = build_real (gnu_result_type, tmp);
- }
+ gcc_assert (Rbase (ur_realval) == 2);
+ real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
+ - UI_To_Int (Denominator (ur_realval)));
+ gnu_result = build_real (gnu_result_type, tmp);
}
/* Now see if we need to negate the result. Do it this way to
int length = String_Length (gnat_string);
int i;
tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
- VEC(constructor_elt,gc) *gnu_vec
- = VEC_alloc (constructor_elt, gc, length);
+ vec<constructor_elt, va_gc> *gnu_vec;
+ vec_alloc (gnu_vec, length);
for (i = 0; i < length; i++)
{
gnu_result = gnu_array_object;
+ /* The failure of this assertion will very likely come from a missing
+ expansion for a packed array access. */
+ gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
+
/* First compute the number of dimensions of the array, then
fill the expression array, the order depending on whether
this is a Convention_Fortran array or not. */
gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
if (Null_Record_Present (gnat_node))
- gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
+ gnu_result = gnat_build_constructor (gnu_aggr_type,
+ NULL);
else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
|| TREE_CODE (gnu_aggr_type) == UNION_TYPE)
}
break;
- case N_Conditional_Expression:
+ case N_If_Expression:
{
tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
/* If the type has a size that overflows, convert this into raise of
Storage_Error: execution shouldn't have gotten here anyway. */
if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
- && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
+ && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
N_Raise_Storage_Error);
else if (Nkind (Expression (gnat_node)) == N_Function_Call)
gnu_result
- = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
+ = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
atomic_sync_required_p (Name (gnat_node)));
else
{
break;
case N_Block_Statement:
- start_stmt_group ();
- gnat_pushlevel ();
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
- add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
- gnat_poplevel ();
- gnu_result = end_stmt_group ();
-
- if (Present (Identifier (gnat_node)))
- mark_out_of_scope (Entity (Identifier (gnat_node)));
+ /* The only way to enter the block is to fall through to it. */
+ if (stmt_group_may_fallthru ())
+ {
+ start_stmt_group ();
+ gnat_pushlevel ();
+ process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+ add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
+ gnat_poplevel ();
+ gnu_result = end_stmt_group ();
+ }
+ else
+ gnu_result = alloc_stmt_list ();
break;
case N_Exit_Statement:
? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
(Present (Name (gnat_node))
? get_gnu_tree (Entity (Name (gnat_node)))
- : VEC_last (loop_info, gnu_loop_stack)->label));
+ : gnu_loop_stack->last ()->label));
break;
- case N_Return_Statement:
+ case N_Simple_Return_Statement:
{
tree gnu_ret_obj, gnu_ret_val;
/* If this function has copy-in/copy-out parameters, get the real
object for the return. See Subprogram_to_gnu. */
if (TYPE_CI_CO_LIST (gnu_subprog_type))
- gnu_ret_obj = VEC_last (tree, gnu_return_var_stack);
+ gnu_ret_obj = gnu_return_var_stack->last ();
else
gnu_ret_obj = DECL_RESULT (current_function_decl);
/* If we have a return label defined, convert this into a branch to
that label. The return proper will be handled elsewhere. */
- if (VEC_last (tree, gnu_return_label_stack))
+ if (gnu_return_label_stack->last ())
{
if (gnu_ret_obj)
add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
gnu_ret_val));
gnu_result = build1 (GOTO_EXPR, void_type_node,
- VEC_last (tree, gnu_return_label_stack));
+ gnu_return_label_stack->last ());
/* When not optimizing, make sure the return is preserved. */
if (!optimize && Comes_From_Source (gnat_node))
- DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0;
+ DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0;
}
/* Otherwise, build a regular return. */
case N_Function_Call:
case N_Procedure_Call_Statement:
- gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE, false);
+ gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE, false);
break;
/************************/
case N_Protected_Body_Stub:
case N_Task_Body_Stub:
/* Simply process whatever unit is being inserted. */
- gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
+ if (Present (Library_Unit (gnat_node)))
+ gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
+ else
+ {
+ gcc_assert (type_annotate_only);
+ gnu_result = alloc_stmt_list ();
+ }
break;
case N_Subunit:
break;
case N_Pop_Constraint_Error_Label:
- VEC_pop (tree, gnu_constraint_error_label_stack);
+ gnu_constraint_error_label_stack->pop ();
break;
case N_Pop_Storage_Error_Label:
- VEC_pop (tree, gnu_storage_error_label_stack);
+ gnu_storage_error_label_stack->pop ();
break;
case N_Pop_Program_Error_Label:
- VEC_pop (tree, gnu_program_error_label_stack);
+ gnu_program_error_label_stack->pop ();
break;
/******************************/
/****************/
case N_Expression_With_Actions:
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* This construct doesn't define a scope so we don't wrap the statement
list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it
from unsharing. */
gnu_expr = gnat_to_gnu (Expression (gnat_node));
gnu_result
= build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
break;
case N_Freeze_Entity:
{
tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
- tree gnu_obj_type;
- tree gnu_actual_obj_type = 0;
- tree gnu_obj_size;
-
- /* If this is a thin pointer, we must dereference it to create
- a fat pointer, then go back below to a thin pointer. The
- reason for this is that we need a fat pointer someplace in
- order to properly compute the size. */
+ tree gnu_obj_type, gnu_actual_obj_type;
+
+ /* If this is a thin pointer, we must first dereference it to create
+ a fat pointer, then go back below to a thin pointer. The reason
+ for this is that we need to have a fat pointer someplace in order
+ to properly compute the size. */
if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_unary_op (INDIRECT_REF, NULL_TREE,
gnu_ptr));
- /* If this is an unconstrained array, we know the object must
- have been allocated with the template in front of the object.
- So pass the template address, but get the total size. Do this
- by converting to a thin pointer. */
+ /* If this is a fat pointer, the object must have been allocated with
+ the template in front of the array. So pass the template address,
+ and get the total size; do it by converting to a thin pointer. */
if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr
= convert (build_pointer_type
gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
+ /* If this is a thin pointer, the object must have been allocated with
+ the template in front of the array. So pass the template address,
+ and get the total size. */
+ if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
+ gnu_ptr
+ = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
+ gnu_ptr,
+ fold_build1 (NEGATE_EXPR, sizetype,
+ byte_position
+ (DECL_CHAIN
+ TYPE_FIELDS ((gnu_obj_type)))));
+
+ /* If we have a special dynamic constrained subtype on the node, use
+ it to compute the size; otherwise, use the designated subtype. */
if (Present (Actual_Designated_Subtype (gnat_node)))
{
gnu_actual_obj_type
else
gnu_actual_obj_type = gnu_obj_type;
- gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
-
- if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
- {
- tree gnu_char_ptr_type
- = build_pointer_type (unsigned_char_type_node);
- tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
- gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
- gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
- gnu_ptr, gnu_pos);
- }
-
gnu_result
- = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
+ = build_call_alloc_dealloc (gnu_ptr,
+ TYPE_SIZE_UNIT (gnu_actual_obj_type),
+ gnu_obj_type,
Procedure_To_Call (gnat_node),
Storage_Pool (gnat_node),
gnat_node);
case N_Raise_Constraint_Error:
case N_Raise_Program_Error:
case N_Raise_Storage_Error:
- {
- const int reason = UI_To_Int (Reason (gnat_node));
- const Node_Id gnat_cond = Condition (gnat_node);
- const bool with_extra_info = Exception_Extra_Info
- && !No_Exception_Handlers_Set ()
- && !get_exception_label (kind);
- tree gnu_cond = NULL_TREE;
-
- if (type_annotate_only)
- {
- gnu_result = alloc_stmt_list ();
- break;
- }
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- switch (reason)
- {
- case CE_Access_Check_Failed:
- if (with_extra_info)
- gnu_result = build_call_raise_column (reason, gnat_node);
- break;
-
- case CE_Index_Check_Failed:
- case CE_Range_Check_Failed:
- case CE_Invalid_Data:
- if (Present (gnat_cond)
- && Nkind (gnat_cond) == N_Op_Not
- && Nkind (Right_Opnd (gnat_cond)) == N_In
- && Nkind (Right_Opnd (Right_Opnd (gnat_cond))) == N_Range)
- {
- Node_Id gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
- Node_Id gnat_type = Etype (gnat_index);
- Node_Id gnat_range = Right_Opnd (Right_Opnd (gnat_cond));
- tree gnu_index = gnat_to_gnu (gnat_index);
- tree gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range));
- tree gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range));
- struct range_check_info_d *rci;
-
- if (with_extra_info
- && Known_Esize (gnat_type)
- && UI_To_Int (Esize (gnat_type)) <= 32)
- gnu_result
- = build_call_raise_range (reason, gnat_node, gnu_index,
- gnu_low_bound, gnu_high_bound);
-
- /* If loop unswitching is enabled, we try to compute invariant
- conditions for checks applied to iteration variables, i.e.
- conditions that are both independent of the variable and
- necessary in order for the check to fail in the course of
- some iteration, and prepend them to the original condition
- of the checks. This will make it possible later for the
- loop unswitching pass to replace the loop with two loops,
- one of which has the checks eliminated and the other has
- the original checks reinstated, and a run time selection.
- The former loop will be suitable for vectorization. */
- if (flag_unswitch_loops
- && (gnu_low_bound = gnat_invariant_expr (gnu_low_bound))
- && (gnu_high_bound = gnat_invariant_expr (gnu_high_bound))
- && (rci = push_range_check_info (gnu_index)))
- {
- rci->low_bound = gnu_low_bound;
- rci->high_bound = gnu_high_bound;
- rci->type = gnat_to_gnu_type (gnat_type);
- rci->invariant_cond = build1 (SAVE_EXPR, boolean_type_node,
- boolean_true_node);
- gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
- boolean_type_node,
- rci->invariant_cond,
- gnat_to_gnu (gnat_cond));
- }
- }
- break;
-
- default:
- break;
- }
-
- if (gnu_result == error_mark_node)
- gnu_result = build_call_raise (reason, gnat_node, kind);
-
- set_expr_location_from_node (gnu_result, gnat_node);
-
- /* If the type is VOID, this is a statement, so we need to generate
- the code for the call. Handle a condition, if there is one. */
- if (VOID_TYPE_P (gnu_result_type))
- {
- if (Present (gnat_cond))
- {
- if (!gnu_cond)
- gnu_cond = gnat_to_gnu (gnat_cond);
- gnu_result
- = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
- alloc_stmt_list ());
- }
- }
- else
- gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
- }
+ if (type_annotate_only)
+ gnu_result = alloc_stmt_list ();
+ else
+ gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type);
break;
case N_Validate_Unchecked_Conversion:
- {
- Entity_Id gnat_target_type = Target_Type (gnat_node);
- tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
- tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
-
- /* No need for any warning in this case. */
- if (!flag_strict_aliasing)
- ;
-
- /* If the result is a pointer type, see if we are either converting
- from a non-pointer or from a pointer to a type with a different
- alias set and warn if so. If the result is defined in the same
- unit as this unchecked conversion, we can allow this because we
- can know to make the pointer type behave properly. */
- else if (POINTER_TYPE_P (gnu_target_type)
- && !In_Same_Source_Unit (gnat_target_type, gnat_node)
- && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
- {
- tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
- ? TREE_TYPE (gnu_source_type)
- : NULL_TREE;
- tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
-
- if ((TYPE_IS_DUMMY_P (gnu_target_desig_type)
- || get_alias_set (gnu_target_desig_type) != 0)
- && (!POINTER_TYPE_P (gnu_source_type)
- || (TYPE_IS_DUMMY_P (gnu_source_desig_type)
- != TYPE_IS_DUMMY_P (gnu_target_desig_type))
- || (TYPE_IS_DUMMY_P (gnu_source_desig_type)
- && gnu_source_desig_type != gnu_target_desig_type)
- || !alias_sets_conflict_p
- (get_alias_set (gnu_source_desig_type),
- get_alias_set (gnu_target_desig_type))))
- {
- post_error_ne
- ("?possible aliasing problem for type&",
- gnat_node, Target_Type (gnat_node));
- post_error
- ("\\?use -fno-strict-aliasing switch for references",
- gnat_node);
- post_error_ne
- ("\\?or use `pragma No_Strict_Aliasing (&);`",
- gnat_node, Target_Type (gnat_node));
- }
- }
+ /* The only validation we currently do on an unchecked conversion is
+ that of aliasing assumptions. */
+ if (flag_strict_aliasing)
+ gnat_validate_uc_list.safe_push (gnat_node);
+ gnu_result = alloc_stmt_list ();
+ break;
- /* But if the result is a fat pointer type, we have no mechanism to
- do that, so we unconditionally warn in problematic cases. */
- else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
- {
- tree gnu_source_array_type
- = TYPE_IS_FAT_POINTER_P (gnu_source_type)
- ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
- : NULL_TREE;
- tree gnu_target_array_type
- = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
-
- if ((TYPE_IS_DUMMY_P (gnu_target_array_type)
- || get_alias_set (gnu_target_array_type) != 0)
- && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
- || (TYPE_IS_DUMMY_P (gnu_source_array_type)
- != TYPE_IS_DUMMY_P (gnu_target_array_type))
- || (TYPE_IS_DUMMY_P (gnu_source_array_type)
- && gnu_source_array_type != gnu_target_array_type)
- || !alias_sets_conflict_p
- (get_alias_set (gnu_source_array_type),
- get_alias_set (gnu_target_array_type))))
- {
- post_error_ne
- ("?possible aliasing problem for type&",
- gnat_node, Target_Type (gnat_node));
- post_error
- ("\\?use -fno-strict-aliasing switch for references",
- gnat_node);
- }
- }
- }
+ case N_Function_Specification:
+ case N_Procedure_Specification:
+ case N_Op_Concat:
+ case N_Component_Association:
+ case N_Protected_Body:
+ case N_Task_Body:
+ /* These nodes should only be present when annotating types. */
+ gcc_assert (type_annotate_only);
gnu_result = alloc_stmt_list ();
break;
default:
- /* SCIL nodes require no processing for GCC. Other nodes should only
- be present when annotating types. */
- gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only);
- gnu_result = alloc_stmt_list ();
+ /* Other nodes are not supposed to reach here. */
+ gcc_unreachable ();
}
/* If we pushed the processing of the elaboration routine, pop it back. */
else if (TREE_CODE (gnu_result) == CALL_EXPR
&& TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
+ && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result)))
+ == gnu_result_type
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
- {
- /* ??? We need to convert if the padded type has fixed size because
- gnat_types_compatible_p will say that padded types are compatible
- but the gimplifier will not and, therefore, will ultimately choke
- if there isn't a conversion added early. */
- if (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result))) == INTEGER_CST)
- gnu_result = convert (gnu_result_type, gnu_result);
- }
+ ;
else if (TREE_TYPE (gnu_result) != gnu_result_type)
gnu_result = convert (gnu_result_type, gnu_result);
label to push onto the stack. */
static void
-push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label)
+push_exception_label_stack (vec<tree, va_gc> **gnu_stack, Entity_Id gnat_label)
{
tree gnu_label = (Present (gnat_label)
? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
: NULL_TREE);
- VEC_safe_push (tree, gc, *gnu_stack, gnu_label);
+ vec_safe_push (*gnu_stack, gnu_label);
}
\f
/* Record the current code position in GNAT_NODE. */
gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
- /* If we are global, we don't want to actually output the DECL_EXPR for
- this decl since we already have evaluated the expressions in the
+ /* If we are external or global, we don't want to output the DECL_EXPR for
+ this DECL node since we already have evaluated the expressions in the
sizes and positions as globals and doing it again would be wrong. */
- if (global_bindings_p ())
+ if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ())
{
/* Mark everything as used to prevent node sharing with subprograms.
Note that walk_tree knows how to deal with TYPE_DECL, but neither
&& !TYPE_FAT_POINTER_P (type))
MARK_VISITED (TYPE_ADA_SIZE (type));
}
- else if (!DECL_EXTERNAL (gnu_decl))
+ else
add_stmt_with_node (gnu_stmt, gnat_entity);
/* If this is a variable and an initializer is attached to it, it must be
return gnu_retval;
}
+/* Return whether the current statement group may fall through. */
+
+static inline bool
+stmt_group_may_fallthru (void)
+{
+ if (current_stmt_group->stmt_list)
+ return block_may_fallthru (current_stmt_group->stmt_list);
+ else
+ return true;
+}
+
/* Add a list of statements from GNAT_LIST, a possibly-empty list of
statements.*/
emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
{
tree gnu_range_type = get_unpadded_type (gnat_range_type);
- tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
- tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
/* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
if (gnu_compare_type == gnu_range_type)
return gnu_expr;
+ /* Range checks can only be applied to types with ranges. */
+ gcc_assert (INTEGRAL_TYPE_P (gnu_range_type)
+ || SCALAR_FLOAT_TYPE_P (gnu_range_type));
+
/* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
we can't do anything since we might be truncating the bounds. No
check is needed in this case. */
(build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
invert_truthvalue
(build_binary_op (GE_EXPR, boolean_type_node,
- convert (gnu_compare_type, gnu_expr),
- convert (gnu_compare_type, gnu_low))),
+ convert (gnu_compare_type, gnu_expr),
+ convert (gnu_compare_type,
+ TYPE_MIN_VALUE
+ (gnu_range_type)))),
invert_truthvalue
(build_binary_op (LE_EXPR, boolean_type_node,
convert (gnu_compare_type, gnu_expr),
convert (gnu_compare_type,
- gnu_high)))),
+ TYPE_MAX_VALUE
+ (gnu_range_type))))),
gnu_expr, CE_Range_Check_Failed, gnat_node);
}
\f
{
tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
tree gnu_expr;
- VEC(constructor_elt,gc) *gnu_expr_vec = NULL;
+ vec<constructor_elt, va_gc> *gnu_expr_vec = NULL;
for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
{
extract_values (tree values, tree record_type)
{
tree field, tem;
- VEC(constructor_elt,gc) *v = NULL;
+ vec<constructor_elt, va_gc> *v = NULL;
for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
{
{
value = extract_values (values, TREE_TYPE (field));
if (TREE_CODE (value) == CONSTRUCTOR
- && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
+ && vec_safe_is_empty (CONSTRUCTOR_ELTS (value)))
value = 0;
}
else
return gnat_build_constructor (record_type, v);
}
\f
+/* Process a N_Validate_Unchecked_Conversion node. */
+
+static void
+validate_unchecked_conversion (Node_Id gnat_node)
+{
+ tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
+ tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
+
+ /* If the target is a pointer type, see if we are either converting from a
+ non-pointer or from a pointer to a type with a different alias set and
+ warn if so, unless the pointer has been marked to alias everything. */
+ if (POINTER_TYPE_P (gnu_target_type)
+ && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
+ {
+ tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
+ ? TREE_TYPE (gnu_source_type)
+ : NULL_TREE;
+ tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
+ alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
+
+ if (target_alias_set != 0
+ && (!POINTER_TYPE_P (gnu_source_type)
+ || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
+ target_alias_set)))
+ {
+ post_error_ne ("?possible aliasing problem for type&",
+ gnat_node, Target_Type (gnat_node));
+ post_error ("\\?use -fno-strict-aliasing switch for references",
+ gnat_node);
+ post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
+ gnat_node, Target_Type (gnat_node));
+ }
+ }
+
+ /* Likewise if the target is a fat pointer type, but we have no mechanism to
+ mitigate the problem in this case, so we unconditionally warn. */
+ else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
+ {
+ tree gnu_source_desig_type
+ = TYPE_IS_FAT_POINTER_P (gnu_source_type)
+ ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
+ : NULL_TREE;
+ tree gnu_target_desig_type
+ = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
+ alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
+
+ if (target_alias_set != 0
+ && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
+ || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
+ target_alias_set)))
+ {
+ post_error_ne ("?possible aliasing problem for type&",
+ gnat_node, Target_Type (gnat_node));
+ post_error ("\\?use -fno-strict-aliasing switch for references",
+ gnat_node);
+ }
+ }
+}
+\f
/* EXP is to be treated as an array or record. Handle the cases when it is
an access object and perform the required dereferences. */
get_exception_label (char kind)
{
if (kind == N_Raise_Constraint_Error)
- return VEC_last (tree, gnu_constraint_error_label_stack);
+ return gnu_constraint_error_label_stack->last ();
else if (kind == N_Raise_Storage_Error)
- return VEC_last (tree, gnu_storage_error_label_stack);
+ return gnu_storage_error_label_stack->last ();
else if (kind == N_Raise_Program_Error)
- return VEC_last (tree, gnu_program_error_label_stack);
+ return gnu_program_error_label_stack->last ();
else
return NULL_TREE;
}
tree
get_elaboration_procedure (void)
{
- return VEC_last (tree, gnu_elab_proc_stack);
+ return gnu_elab_proc_stack->last ();
}
#include "gt-ada-trans.h"
projects / platform / upstream / gcc48.git / blobdiff