procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

cuintp.c (UI_To_gnu): Fix long line.

Browse source 
* gcc-interface/cuintp.c (UI_To_gnu): Fix long line.
	* gcc-interface/gigi.h (MARK_VISITED): Skip objects of constant class.
	(process_attributes): Delete.
	(post_error_ne_num): Change parameter name.
	* gcc-interface/decl.c (gnat_to_gnu_entity): Do not force debug info
	with -g3.  Remove a couple of obsolete lines.  Minor tweaks.
	If type annotating mode, operate on trees to compute the adjustment to
	the sizes of tagged types.  Fix long line.
	(cannot_be_superflat_p): Tweak head comment.
	(annotate_value): Fold local constant.
	(set_rm_size): Fix long line.
	* gcc-interface/trans.c (Identifier_to_gnu): Rework comments.
	(Attribute_to_gnu): Fix long line.
	<Attr_Size>: Remove useless assertion.
	Reorder statements.  Use size_binop routine.
	(Loop_Statement_to_gnu): Use build5 in lieu of build_nt.
	Create local variables for the label and the test.  Tweak comments.
	(Subprogram_Body_to_gnu): Reset cfun to NULL.
	(Compilation_Unit_to_gnu): Use the Sloc of the Unit node.
	(process_inlined_subprograms): Integrate into...
	(Compilation_Unit_to_gnu): ...this.
	(gnat_to_gnu): Fix long line.
	(post_error_ne_num): Change parameter name.
	* gcc-interface/utils.c (process_attributes): Static-ify.
	<ATTR_MACHINE_ATTRIBUTE>: Set input_location before proceeding.
	(create_type_decl): Add comment.
	(create_var_decl_1): Process the attributes after adding the VAR_DECL
	to the current binding level.
	(create_subprog_decl): Likewise for the FUNCTION_DECL.
	(end_subprog_body): Do not reset cfun to NULL.
	(build_vms_descriptor32): Fix long line.
	(build_vms_descriptor): Likewise.
	(handle_nonnull_attribute): Likewise.
	(convert_vms_descriptor64): Likewise.
	* gcc-interface/utils2.c (fill_vms_descriptor): Fix long line.
	(gnat_protect_expr): Fix thinko.

From-SVN: r158390
This commit is contained in:
Eric Botcazou 2010-04-15 21:15:47 +00:00 • committed by Eric Botcazou
parent 1fc24649bc
commit 58c8f7700a
7 changed files with 278 additions and 247 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
gcc/ada/ChangeLog
View file

@ -1,3 +1,42 @@
2010-04-15 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/cuintp.c (UI_To_gnu): Fix long line.
* gcc-interface/gigi.h (MARK_VISITED): Skip objects of constant class.
(process_attributes): Delete.
(post_error_ne_num): Change parameter name.
* gcc-interface/decl.c (gnat_to_gnu_entity): Do not force debug info
with -g3. Remove a couple of obsolete lines. Minor tweaks.
If type annotating mode, operate on trees to compute the adjustment to
the sizes of tagged types. Fix long line.
(cannot_be_superflat_p): Tweak head comment.
(annotate_value): Fold local constant.
(set_rm_size): Fix long line.
* gcc-interface/trans.c (Identifier_to_gnu): Rework comments.
(Attribute_to_gnu): Fix long line.
<Attr_Size>: Remove useless assertion.
Reorder statements. Use size_binop routine.
(Loop_Statement_to_gnu): Use build5 in lieu of build_nt.
Create local variables for the label and the test. Tweak comments.
(Subprogram_Body_to_gnu): Reset cfun to NULL.
(Compilation_Unit_to_gnu): Use the Sloc of the Unit node.
(process_inlined_subprograms): Integrate into...
(Compilation_Unit_to_gnu): ...this.
(gnat_to_gnu): Fix long line.
(post_error_ne_num): Change parameter name.
* gcc-interface/utils.c (process_attributes): Static-ify.
<ATTR_MACHINE_ATTRIBUTE>: Set input_location before proceeding.
(create_type_decl): Add comment.
(create_var_decl_1): Process the attributes after adding the VAR_DECL
to the current binding level.
(create_subprog_decl): Likewise for the FUNCTION_DECL.
(end_subprog_body): Do not reset cfun to NULL.
(build_vms_descriptor32): Fix long line.
(build_vms_descriptor): Likewise.
(handle_nonnull_attribute): Likewise.
(convert_vms_descriptor64): Likewise.
* gcc-interface/utils2.c (fill_vms_descriptor): Fix long line.
(gnat_protect_expr): Fix thinko.
2010-04-15 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (gigi): Set DECL_IGNORED_P on EH functions.

3
gcc/ada/gcc-interface/cuintp.c
View file

@ -106,7 +106,8 @@ UI_To_gnu (Uint Input, tree type)
The base integer precision must be superior than 16. */
if (TREE_CODE (comp_type) != REAL_TYPE
&& TYPE_PRECISION (comp_type) < TYPE_PRECISION (long_integer_type_node))
&& TYPE_PRECISION (comp_type)
< TYPE_PRECISION (long_integer_type_node))
{
comp_type = long_integer_type_node;
gcc_assert (TYPE_PRECISION (comp_type) > 16);

76
gcc/ada/gcc-interface/decl.c
View file

@ -207,8 +207,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* True if we made GNU_DECL and its type here. */
bool this_made_decl = false;
/* True if debug info is requested for this entity. */
bool debug_info_p = (Needs_Debug_Info (gnat_entity)
|| debug_info_level == DINFO_LEVEL_VERBOSE);
bool debug_info_p = Needs_Debug_Info (gnat_entity);
/* True if this entity is to be considered as imported. */
bool imported_p = (Is_Imported (gnat_entity)
&& No (Address_Clause (gnat_entity)));
@ -983,8 +982,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
as we have a VAR_DECL for the pointer we make. */
}
gnu_expr
= build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
gnu_expr = build_unary_op (ADDR_EXPR, gnu_type,
maybe_stable_expr);
gnu_size = NULL_TREE;
used_by_ref = true;
@ -1291,10 +1290,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| Is_Exported (gnat_entity)))))
gnu_ext_name = create_concat_name (gnat_entity, NULL);
/* If this is constant initialized to a static constant and the
object has an aggregate type, force it to be statically
allocated. This will avoid an initialization copy. */
if (!static_p && const_flag
/* If this is an aggregate constant initialized to a constant, force it
to be statically allocated. This saves an initialization copy. */
if (!static_p
&& const_flag
&& gnu_expr && TREE_CONSTANT (gnu_expr)
&& AGGREGATE_TYPE_P (gnu_type)
&& host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
@ -1303,11 +1302,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
(TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
static_p = true;
gnu_decl = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_expr, const_flag,
Is_Public (gnat_entity),
imported_p || !definition,
static_p, attr_list, gnat_entity);
gnu_decl
= create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_expr, const_flag, Is_Public (gnat_entity),
imported_p || !definition, static_p, attr_list,
gnat_entity);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
@ -3473,7 +3472,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
TYPE_POINTER_TO (gnu_old) = gnu_type;
Sloc_to_locus (Sloc (gnat_entity), &input_location);
fields
= chainon (chainon (NULL_TREE,
create_field_decl
@ -4170,8 +4168,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
| (TYPE_QUAL_CONST * const_flag)
| (TYPE_QUAL_VOLATILE * volatile_flag));
Sloc_to_locus (Sloc (gnat_entity), &input_location);
if (has_stub)
gnu_stub_type
= build_qualified_type (gnu_stub_type,
@ -4705,38 +4701,40 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
{
/* If the size is self-referential, we annotate the maximum
value of that size. */
tree gnu_size = TYPE_SIZE (gnu_type);
/* If the size is self-referential, annotate the maximum value. */
if (CONTAINS_PLACEHOLDER_P (gnu_size))
gnu_size = max_size (gnu_size, true);
Set_Esize (gnat_entity, annotate_value (gnu_size));
if (type_annotate_only && Is_Tagged_Type (gnat_entity))
{
/* In this mode the tag and the parent components are not
generated by the front-end, so the sizes must be adjusted
explicitly now. */
int size_offset, new_size;
/* In this mode, the tag and the parent components are not
generated by the front-end so the sizes must be adjusted. */
tree pointer_size = bitsize_int (POINTER_SIZE), offset;
Uint uint_size;
if (Is_Derived_Type (gnat_entity))
{
size_offset
= UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
offset = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
bitsizetype);
Set_Alignment (gnat_entity,
Alignment (Etype (Base_Type (gnat_entity))));
}
else
size_offset = POINTER_SIZE;
offset = pointer_size;
new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
Set_Esize (gnat_entity,
UI_From_Int (((new_size + (POINTER_SIZE - 1))
/ POINTER_SIZE) * POINTER_SIZE));
Set_RM_Size (gnat_entity, Esize (gnat_entity));
gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
gnu_size = size_binop (MULT_EXPR, pointer_size,
size_binop (CEIL_DIV_EXPR,
gnu_size,
pointer_size));
uint_size = annotate_value (gnu_size);
Set_Esize (gnat_entity, uint_size);
Set_RM_Size (gnat_entity, uint_size);
}
else
Set_Esize (gnat_entity, annotate_value (gnu_size));
}
if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
@ -5366,15 +5364,14 @@ compile_time_known_address_p (Node_Id gnat_address)
return Compile_Time_Known_Value (gnat_address);
}
/* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e.
cannot verify HB < LB-1 when LB and HB are the low and high bounds. */
/* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
static bool
cannot_be_superflat_p (Node_Id gnat_range)
{
Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
Node_Id scalar_range;
tree gnu_lb, gnu_hb;
/* If the low bound is not constant, try to find an upper bound. */
@ -7087,12 +7084,10 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
static Uint
annotate_value (tree gnu_size)
{
int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
TCode tcode;
Node_Ref_Or_Val ops[3], ret;
int i;
int size;
struct tree_int_map **h = NULL;
int size, i;
/* See if we've already saved the value for this node. */
if (EXPR_P (gnu_size))
@ -7223,7 +7218,7 @@ annotate_value (tree gnu_size)
for (i = 0; i < 3; i++)
ops[i] = No_Uint;
for (i = 0; i < len; i++)
for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
{
ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
if (ops[i] == No_Uint)
@ -7675,7 +7670,8 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
&& TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
&& !(TYPE_IS_PADDING_P (gnu_type)
&& TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
&& TYPE_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type))))
&& TYPE_PACKED_ARRAY_TYPE_P
(TREE_TYPE (TYPE_FIELDS (gnu_type))))
&& tree_int_cst_lt (size, old_size)))
{
if (Present (gnat_attr_node))

13
gcc/ada/gcc-interface/gigi.h
View file

@ -85,7 +85,7 @@ extern void mark_visited (tree t);
#define MARK_VISITED(EXP) \
do { \
if((EXP) && !TREE_CONSTANT (EXP)) \
if((EXP) && !CONSTANT_CLASS_P (EXP)) \
mark_visited (EXP); \
} while (0)
@ -240,9 +240,9 @@ extern void post_error (const char *msg, Node_Id node);
extern void post_error_ne (const char *msg, Node_Id node, Entity_Id ent);
/* Similar, but NODE is the node at which to post the error, ENT is the node
to use for the "&" substitution, and N is the number to use for the ^. */
to use for the "&" substitution, and NUM is the number to use for ^. */
extern void post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent,
int n);
int num);
/* Similar to post_error_ne_num, but T is a GCC tree representing the number
to write. If the tree represents a constant that fits within a
@ -252,8 +252,8 @@ extern void post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent,
extern void post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent,
tree t);
/* Similar to post_error_ne_tree, except that NUM is a second
integer to write in the message. */
/* Similar to post_error_ne_tree, except that NUM is a second integer to write
in the message. */
extern void post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent,
tree t, int num);
@ -622,9 +622,6 @@ create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
const_flag, public_flag, extern_flag, \
static_flag, false, attr_list, gnat_node)
/* Given a DECL and ATTR_LIST, apply the listed attributes. */
extern void process_attributes (tree decl, struct attrib *attr_list);
/* Record DECL as a global renaming pointer. */
extern void record_global_renaming_pointer (tree decl);

218
gcc/ada/gcc-interface/trans.c
View file

@ -200,7 +200,6 @@ static void pop_stack (tree *);
static enum gimplify_status gnat_gimplify_stmt (tree *);
static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
static void process_inlined_subprograms (Node_Id);
static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
static tree emit_range_check (tree, Node_Id, Node_Id);
static tree emit_index_check (tree, tree, tree, tree, Node_Id);
@ -1034,10 +1033,9 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
}
/* If we have a constant declaration and its initializer at hand,
try to return the latter to avoid the need to call fold in lots
of places and the need of elaboration code if this Id is used as
an initializer itself. */
/* If we have a constant declaration and its initializer, try to return the
latter to avoid the need to call fold in lots of places and the need for
elaboration code if this identifier is used as an initializer itself. */
if (TREE_CONSTANT (gnu_result)
&& DECL_P (gnu_result)
&& DECL_INITIAL (gnu_result))
@ -1055,11 +1053,15 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
= 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. */
if ((constant_only && !address_of_constant) || !require_lvalue)
gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
}
*gnu_result_type_p = gnu_result_type;
return gnu_result;
}
@ -1357,7 +1359,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
tree gnu_byte_offset
= convert (sizetype,
size_diffop (size_zero_node, gnu_pos));
gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
gnu_byte_offset
= fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
@ -1456,17 +1459,14 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
else
gnu_result = rm_size (gnu_type);
gcc_assert (gnu_result);
/* Deal with a self-referential size by returning the maximum size for
a type and by qualifying the size with the object for 'Size of an
object. */
a type and by qualifying the size with the object otherwise. */
if (CONTAINS_PLACEHOLDER_P (gnu_result))
{
if (TREE_CODE (gnu_prefix) != TYPE_DECL)
gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
else
if (TREE_CODE (gnu_prefix) == TYPE_DECL)
gnu_result = max_size (gnu_result, true);
else
gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
}
/* If the type contains a template, subtract its size. */
@ -1475,11 +1475,11 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
gnu_result = size_binop (MINUS_EXPR, gnu_result,
DECL_SIZE (TYPE_FIELDS (gnu_type)));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* For 'Max_Size_In_Storage_Elements, adjust the unit. */
if (attribute == Attr_Max_Size_In_Storage_Elements)
gnu_result = fold_build2 (CEIL_DIV_EXPR, bitsizetype,
gnu_result, bitsize_unit_node);
gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
gnu_result_type = get_unpadded_type (Etype (gnat_node));
break;
case Attr_Alignment:
@ -2052,25 +2052,22 @@ Case_Statement_to_gnu (Node_Id gnat_node)
static tree
Loop_Statement_to_gnu (Node_Id gnat_node)
{
/* ??? It would be nice to use "build" here, but there's no build5. */
tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
NULL_TREE, NULL_TREE, NULL_TREE);
tree gnu_loop_var = NULL_TREE;
Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
tree gnu_cond_expr = NULL_TREE;
const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
tree gnu_loop_stmt = build5 (LOOP_STMT, void_type_node, NULL_TREE,
NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE);
tree gnu_loop_label = create_artificial_label (input_location);
tree gnu_loop_var = NULL_TREE, gnu_cond_expr = NULL_TREE;
tree gnu_result;
TREE_TYPE (gnu_loop_stmt) = void_type_node;
TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (input_location);
/* Set location information for statement and end label. */
set_expr_location_from_node (gnu_loop_stmt, gnat_node);
Sloc_to_locus (Sloc (End_Label (gnat_node)),
&DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt)));
&DECL_SOURCE_LOCATION (gnu_loop_label));
LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
/* Save the end label of this LOOP_STMT in a stack so that the corresponding
/* Save the end label of this LOOP_STMT in a stack so that a corresponding
N_Exit_Statement can find it. */
push_stack (&gnu_loop_label_stack, NULL_TREE,
LOOP_STMT_LABEL (gnu_loop_stmt));
push_stack (&gnu_loop_label_stack, NULL_TREE, gnu_loop_label);
/* Set the condition under which the loop must keep going.
For the case "LOOP .... END LOOP;" the condition is always true. */
@ -2082,8 +2079,8 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
LOOP_STMT_TOP_COND (gnu_loop_stmt)
= gnat_to_gnu (Condition (gnat_iter_scheme));
/* Otherwise we have an iteration scheme and the condition is given by
the bounds of the subtype of the iteration variable. */
/* Otherwise we have an iteration scheme and the condition is given by the
bounds of the subtype of the iteration variable. */
else
{
Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
@ -2092,18 +2089,18 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
tree gnu_type = get_unpadded_type (gnat_type);
tree gnu_low = TYPE_MIN_VALUE (gnu_type);
tree gnu_high = TYPE_MAX_VALUE (gnu_type);
tree gnu_first, gnu_last, gnu_limit;
enum tree_code update_code, end_code;
tree gnu_base_type = get_base_type (gnu_type);
tree gnu_first, gnu_last, gnu_limit, gnu_test;
enum tree_code update_code, test_code;
/* We must disable modulo reduction for the loop variable, if any,
/* We must disable modulo reduction for the iteration variable, if any,
in order for the loop comparison to be effective. */
if (Reverse_Present (gnat_loop_spec))
{
gnu_first = gnu_high;
gnu_last = gnu_low;
update_code = MINUS_NOMOD_EXPR;
end_code = GE_EXPR;
test_code = GE_EXPR;
gnu_limit = TYPE_MIN_VALUE (gnu_base_type);
}
else
@ -2111,14 +2108,15 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
gnu_first = gnu_low;
gnu_last = gnu_high;
update_code = PLUS_NOMOD_EXPR;
end_code = LE_EXPR;
test_code = LE_EXPR;
gnu_limit = TYPE_MAX_VALUE (gnu_base_type);
}
/* We know the loop variable will not overflow if GNU_LAST is a constant
and is not equal to GNU_LIMIT. If it might overflow, we have to move
the limit test to the end of the loop. In that case, we have to test
for an empty loop outside the loop. */
/* We know that the iteration variable will not overflow if GNU_LAST is
a constant and is not equal to GNU_LIMIT. If it might overflow, we
have to turn the limit test into an inequality test and move it to
the end of the loop; as a consequence, we also have to test for an
empty loop before entering it. */
if (TREE_CODE (gnu_last) != INTEGER_CST
|| TREE_CODE (gnu_limit) != INTEGER_CST
|| tree_int_cst_equal (gnu_last, gnu_limit))
@ -2129,32 +2127,30 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
gnu_low, gnu_high),
NULL_TREE, alloc_stmt_list ());
set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
test_code = NE_EXPR;
}
/* Open a new nesting level that will surround the loop to declare the
loop index variable. */
iteration variable. */
start_stmt_group ();
gnat_pushlevel ();
/* Declare the loop index and set it to its initial value. */
/* Declare the iteration variable and set it to its initial value. */
gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
if (DECL_BY_REF_P (gnu_loop_var))
gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
/* The loop variable might be a padded type, so use `convert' to get a
reference to the inner variable if so. */
gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
/* Do all the arithmetics in the base type. */
gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
/* Set either the top or bottom exit condition as appropriate depending
on whether or not we know an overflow cannot occur. */
gnu_test = build_binary_op (test_code, integer_type_node, gnu_loop_var,
gnu_last);
if (gnu_cond_expr)
LOOP_STMT_BOT_COND (gnu_loop_stmt)
= build_binary_op (NE_EXPR, integer_type_node,
gnu_loop_var, gnu_last);
LOOP_STMT_BOT_COND (gnu_loop_stmt) = gnu_test;
else
LOOP_STMT_TOP_COND (gnu_loop_stmt)
= build_binary_op (end_code, integer_type_node,
gnu_loop_var, gnu_last);
LOOP_STMT_TOP_COND (gnu_loop_stmt) = gnu_test;
LOOP_STMT_UPDATE (gnu_loop_stmt)
= build_binary_op (MODIFY_EXPR, NULL_TREE,
@ -2169,16 +2165,15 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
}
/* If the loop was named, have the name point to this loop. In this case,
the association is not a ..._DECL node, but the end label from this
LOOP_STMT. */
the association is not a DECL node, but the end label of the loop. */
if (Present (Identifier (gnat_node)))
save_gnu_tree (Entity (Identifier (gnat_node)),
LOOP_STMT_LABEL (gnu_loop_stmt), true);
save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
/* Make the loop body into its own block, so any allocated storage will be
released every iteration. This is needed for stack allocation. */
LOOP_STMT_BODY (gnu_loop_stmt)
= build_stmt_group (Statements (gnat_node), true);
TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
/* If we declared a variable, then we are in a statement group for that
declaration. Add the LOOP_STMT to it and make that the "loop". */
@ -2325,13 +2320,14 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
allocate_struct_function (gnu_subprog_decl, false);
DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
= GGC_CNEW (struct language_function);
set_cfun (NULL);
begin_subprog_body (gnu_subprog_decl);
gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
/* If there are Out parameters, we need to ensure that the return statement
properly copies them out. We do this by making a new block and converting
any inner return into a goto to a label at the end of the block. */
gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
push_stack (&gnu_return_label_stack, NULL_TREE,
gnu_cico_list ? create_artificial_label (input_location)
: NULL_TREE);
@ -3422,26 +3418,26 @@ Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
static void
Compilation_Unit_to_gnu (Node_Id gnat_node)
{
const Node_Id gnat_unit = Unit (gnat_node);
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);
/* Make the decl for the elaboration procedure. */
bool body_p = (Defining_Entity (Unit (gnat_node)),
Nkind (Unit (gnat_node)) == N_Package_Body
|| Nkind (Unit (gnat_node)) == N_Subprogram_Body);
Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
tree gnu_elab_proc_decl
= create_subprog_decl
(create_concat_name (gnat_unit_entity,
body_p ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
gnat_unit_entity);
(create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, gnat_unit);
struct elab_info *info;
push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
/* Initialize the information structure for the function. */
allocate_struct_function (gnu_elab_proc_decl, false);
Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
current_function_decl = NULL_TREE;
set_cfun (NULL);
current_function_decl = NULL_TREE;
start_stmt_group ();
gnat_pushlevel ();
@ -3454,7 +3450,34 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
finalize_from_with_types ();
}
process_inlined_subprograms (gnat_node);
/* If we can inline, generate code for all the inlined subprograms. */
if (optimize)
{
Entity_Id gnat_entity;
for (gnat_entity = First_Inlined_Subprogram (gnat_node);
Present (gnat_entity);
gnat_entity = Next_Inlined_Subprogram (gnat_entity))
{
Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
if (Nkind (gnat_body) != N_Subprogram_Body)
{
/* ??? This really should always be present. */
if (No (Corresponding_Body (gnat_body)))
continue;
gnat_body
= Parent (Declaration_Node (Corresponding_Body (gnat_body)));
}
if (Present (gnat_body))
{
/* Define the entity first so we set DECL_EXTERNAL. */
gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
add_stmt (gnat_to_gnu (gnat_body));
}
}
}
if (type_annotate_only && gnat_node == Cunit (Main_Unit))
{
@ -3481,6 +3504,11 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
set_current_block_context (gnu_elab_proc_decl);
gnat_poplevel ();
DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
Sloc_to_locus
(Sloc (gnat_unit),
&DECL_STRUCT_FUNCTION (gnu_elab_proc_decl)->function_end_locus);
info->next = elab_info_list;
info->elab_proc = gnu_elab_proc_decl;
info->gnat_node = gnat_node;
@ -5220,7 +5248,8 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_actual_obj_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
get_identifier ("DEALLOC"));
get_identifier
("DEALLOC"));
}
else
gnu_actual_obj_type = gnu_obj_type;
@ -5235,7 +5264,8 @@ gnat_to_gnu (Node_Id gnat_node)
tree gnu_byte_offset
= convert (sizetype,
size_diffop (size_zero_node, gnu_pos));
gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
gnu_byte_offset
= fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
@ -6219,42 +6249,6 @@ process_freeze_entity (Node_Id gnat_node)
TREE_TYPE (gnu_new));
}
/* Process the list of inlined subprograms of GNAT_NODE, which is an
N_Compilation_Unit. */
static void
process_inlined_subprograms (Node_Id gnat_node)
{
Entity_Id gnat_entity;
Node_Id gnat_body;
/* If we can inline, generate Gimple for all the inlined subprograms.
Define the entity first so we set DECL_EXTERNAL. */
if (optimize > 0)
for (gnat_entity = First_Inlined_Subprogram (gnat_node);
Present (gnat_entity);
gnat_entity = Next_Inlined_Subprogram (gnat_entity))
{
gnat_body = Parent (Declaration_Node (gnat_entity));
if (Nkind (gnat_body) != N_Subprogram_Body)
{
/* ??? This really should always be Present. */
if (No (Corresponding_Body (gnat_body)))
continue;
gnat_body
= Parent (Declaration_Node (Corresponding_Body (gnat_body)));
}
if (Present (gnat_body))
{
gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
add_stmt (gnat_to_gnu (gnat_body));
}
}
}
/* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
We make two passes, one to elaborate anything other than bodies (but
we declare a function if there was no spec). The second pass
@ -7428,17 +7422,17 @@ post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
}
/* Similar, but NODE is the node at which to post the error, ENT is the node
to use for the "&" substitution, and N is the number to use for the ^. */
to use for the "&" substitution, and NUM is the number to use for ^. */
void
post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
{
String_Template temp;
Fat_Pointer fp;
temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
fp.Array = msg, fp.Bounds = &temp;
Error_Msg_Uint_1 = UI_From_Int (n);
Error_Msg_Uint_1 = UI_From_Int (num);
if (Present (node))
Error_Msg_NE (fp, node, ent);
@ -7495,8 +7489,8 @@ post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
Error_Msg_NE (fp, node, ent);
}
/* Similar to post_error_ne_tree, except that NUM is a second
integer to write in the message. */
/* Similar to post_error_ne_tree, except that NUM is a second integer to write
in the message. */
void
post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,

164
gcc/ada/gcc-interface/utils.c
View file

@ -203,6 +203,7 @@ static tree convert_to_fat_pointer (tree, tree);
static tree convert_to_thin_pointer (tree, tree);
static tree make_descriptor_field (const char *,tree, tree, tree);
static bool potential_alignment_gap (tree, tree, tree);
static void process_attributes (tree, struct attrib *);
/* Initialize the association of GNAT nodes to GCC trees. */
@ -1283,7 +1284,10 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list,
TYPE_DECL, type_name, type);
DECL_ARTIFICIAL (type_decl) = artificial_p;
/* Add this decl to the current binding level. */
gnat_pushdecl (type_decl, gnat_node);
process_attributes (type_decl, attr_list);
/* If we're naming the type, equate the TYPE_STUB_DECL to the name.
@ -1413,21 +1417,17 @@ create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
!= null_pointer_node)
DECL_IGNORED_P (var_decl) = 1;
if (TREE_CODE (var_decl) == VAR_DECL)
{
if (asm_name)
SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
process_attributes (var_decl, attr_list);
}
/* Add this decl to the current binding level. */
gnat_pushdecl (var_decl, gnat_node);
if (TREE_SIDE_EFFECTS (var_decl))
TREE_ADDRESSABLE (var_decl) = 1;
if (TREE_CODE (var_decl) != CONST_DECL)
if (TREE_CODE (var_decl) == VAR_DECL)
{
if (asm_name)
SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
process_attributes (var_decl, attr_list);
if (global_bindings_p ())
rest_of_decl_compilation (var_decl, true, 0);
}
@ -1647,13 +1647,14 @@ create_param_decl (tree param_name, tree param_type, bool readonly)
/* Given a DECL and ATTR_LIST, process the listed attributes. */
void
static void
process_attributes (tree decl, struct attrib *attr_list)
{
for (; attr_list; attr_list = attr_list->next)
switch (attr_list->type)
{
case ATTR_MACHINE_ATTRIBUTE:
input_location = DECL_SOURCE_LOCATION (decl);
decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
NULL_TREE),
ATTR_FLAG_TYPE_IN_PLACE);
@ -1863,11 +1864,11 @@ create_subprog_decl (tree subprog_name, tree asm_name,
DECL_NAME (subprog_decl) = main_identifier_node;
}
process_attributes (subprog_decl, attr_list);
/* Add this decl to the current binding level. */
gnat_pushdecl (subprog_decl, gnat_node);
process_attributes (subprog_decl, attr_list);
/* Output the assembler code and/or RTL for the declaration. */
rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
@ -1883,9 +1884,10 @@ begin_subprog_body (tree subprog_decl)
{
tree param_decl;
current_function_decl = subprog_decl;
announce_function (subprog_decl);
current_function_decl = subprog_decl;
/* Enter a new binding level and show that all the parameters belong to
this function. */
gnat_pushlevel ();
@ -1926,7 +1928,6 @@ end_subprog_body (tree body)
DECL_SAVED_TREE (fndecl) = body;
current_function_decl = DECL_CONTEXT (fndecl);
set_cfun (NULL);
/* We cannot track the location of errors past this point. */
error_gnat_node = Empty;
@ -2329,12 +2330,12 @@ build_template (tree template_type, tree array_type, tree expr)
return gnat_build_constructor (template_type, nreverse (template_elts));
}
/* Build a 32bit 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. */
/* 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)
@ -2473,25 +2474,24 @@ build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
break;
}
/* Make the type for a descriptor for VMS. The first four fields
are the same for all types. */
/* Make the type for a descriptor for VMS. The first four fields are the
same for all types. */
field_list
= chainon (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 = chainon (field_list,
make_descriptor_field ("DTYPE",
gnat_type_for_size (8, 1),
record_type, size_int (dtype)));
field_list = chainon (field_list,
make_descriptor_field ("CLASS",
gnat_type_for_size (8, 1),
record_type, size_int (klass)));
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
= chainon (field_list,
make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1),
record_type, size_int (dtype)));
field_list
= chainon (field_list,
make_descriptor_field ("CLASS", gnat_type_for_size (8, 1),
record_type, size_int (klass)));
/* Of course this will crash at run-time if the address space is not
within the low 32 bits, but there is nothing else we can do. */
@ -2499,11 +2499,11 @@ build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
field_list
= chainon (field_list,
make_descriptor_field
("POINTER", pointer32_type, record_type,
build_unary_op (ADDR_EXPR,
pointer32_type,
build0 (PLACEHOLDER_EXPR, type))));
make_descriptor_field ("POINTER", pointer32_type, record_type,
build_unary_op (ADDR_EXPR,
pointer32_type,
build0 (PLACEHOLDER_EXPR,
type))));
switch (mech)
{
@ -2644,12 +2644,12 @@ build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
return record_type;
}
/* 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 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. */
/* 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)
@ -2783,43 +2783,41 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
break;
}
/* Make the type for a 64bit descriptor for VMS. The first six fields
/* Make the type for a 64-bit descriptor for VMS. The first six fields
are the same for all types. */
field_list64 = chainon (field_list64,
make_descriptor_field ("MBO",
gnat_type_for_size (16, 1),
record64_type, size_int (1)));
field_list64 = chainon (field_list64,
make_descriptor_field ("DTYPE",
gnat_type_for_size (8, 1),
record64_type, size_int (dtype)));
field_list64 = chainon (field_list64,
make_descriptor_field ("CLASS",
gnat_type_for_size (8, 1),
record64_type, size_int (klass)));
field_list64 = chainon (field_list64,
make_descriptor_field ("MBMO",
gnat_type_for_size (32, 1),
record64_type, ssize_int (-1)));
field_list64
= chainon (field_list64,
make_descriptor_field
("LENGTH", gnat_type_for_size (64, 1), record64_type,
size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
make_descriptor_field ("MBO", gnat_type_for_size (16, 1),
record64_type, size_int (1)));
field_list64
= chainon (field_list64,
make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1),
record64_type, size_int (dtype)));
field_list64
= chainon (field_list64,
make_descriptor_field ("CLASS", gnat_type_for_size (8, 1),
record64_type, size_int (klass)));
field_list64
= chainon (field_list64,
make_descriptor_field ("MBMO", gnat_type_for_size (32, 1),
record64_type, ssize_int (-1)));
field_list64
= chainon (field_list64,
make_descriptor_field ("LENGTH", gnat_type_for_size (64, 1),
record64_type,
size_in_bytes (mech == By_Descriptor_A
? inner_type : type)));
pointer64_type = build_pointer_type_for_mode (type, DImode, false);
field_list64
= chainon (field_list64,
make_descriptor_field
("POINTER", pointer64_type, record64_type,
build_unary_op (ADDR_EXPR,
pointer64_type,
build0 (PLACEHOLDER_EXPR, type))));
make_descriptor_field ("POINTER", pointer64_type,
record64_type,
build_unary_op (ADDR_EXPR,
pointer64_type,
build0 (PLACEHOLDER_EXPR,
type))));
switch (mech)
{
@ -2983,11 +2981,11 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
/* The CLASS field is the 3rd field in the descriptor. */
tree klass = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type)));
/* The POINTER field is the 6th field in the descriptor. */
tree pointer64 = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (klass)));
tree pointer = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (klass)));
/* Retrieve the value of the POINTER field. */
tree gnu_expr64
= build3 (COMPONENT_REF, TREE_TYPE (pointer64), desc, pointer64, NULL_TREE);
= build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
if (POINTER_TYPE_P (gnu_type))
return convert (gnu_type, gnu_expr64);
@ -3033,7 +3031,7 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
/* 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 = TREE_CHAIN (pointer64);
t = TREE_CHAIN (pointer);
lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
@ -3058,7 +3056,7 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
case 4: /* Class A */
/* The AFLAGS field is the 3rd field after the pointer in the
descriptor. */
t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer64)));
t = TREE_CHAIN (TREE_CHAIN (TREE_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. */
@ -5084,7 +5082,8 @@ handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name),
if (!argument
|| TREE_CODE (TREE_VALUE (argument)) == VOID_TYPE)
{
error ("nonnull argument with out-of-range operand number (argument %lu, operand %lu)",
error ("nonnull argument with out-of-range operand number "
"(argument %lu, operand %lu)",
(unsigned long) attr_arg_num, (unsigned long) arg_num);
*no_add_attrs = true;
return NULL_TREE;
@ -5092,7 +5091,8 @@ handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name),
if (TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE)
{
error ("nonnull argument references non-pointer operand (argument %lu, operand %lu)",
error ("nonnull argument references non-pointer operand "
"(argument %lu, operand %lu)",
(unsigned long) attr_arg_num, (unsigned long) arg_num);
*no_add_attrs = true;
return NULL_TREE;

12
gcc/ada/gcc-interface/utils2.c
View file

@ -2121,7 +2121,8 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
convert (long_integer_type_node,
addr64expr),
malloc64low),
build_call_raise (CE_Range_Check_Failed, gnat_actual,
build_call_raise (CE_Range_Check_Failed,
gnat_actual,
N_Raise_Constraint_Error),
NULL_TREE));
}
@ -2228,9 +2229,12 @@ gnat_protect_expr (tree exp)
unshared for gimplification; in order to avoid a complexity explosion
at that point, we protect any expressions more complex than a simple
arithmetic expression. */
if (!TREE_SIDE_EFFECTS (exp)
&& !EXPRESSION_CLASS_P (skip_simple_arithmetic (exp)))
return exp;
if (!TREE_SIDE_EFFECTS (exp))
{
tree inner = skip_simple_arithmetic (exp);
if (!EXPR_P (inner) || REFERENCE_CLASS_P (inner))
return exp;
}
/* If this is a conversion, protect what's inside the conversion. */
if (code == NON_LVALUE_EXPR