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.
(gnat_to_gnu) <N_Op_Eq>: Restore the value of input_location
before translating the top-level node.
/* 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)));
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;
|| 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)
(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)
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
| (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,
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;
-
- 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));
+ offset = pointer_size;
+
+ 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))
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. */
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))
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)
&& 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))
#define MARK_VISITED(EXP) \
do { \
- if((EXP) && !TREE_CONSTANT (EXP)) \
+ if((EXP) && !CONSTANT_CLASS_P (EXP)) \
mark_visited (EXP); \
} while (0)
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
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);
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);
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);
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))
= 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;
}
\f
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,
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. */
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:
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. */
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);
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
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))
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,
}
/* 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". */
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);
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 ();
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))
{
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;
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;
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,
TREE_TYPE (gnu_new));
}
\f
-/* 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));
- }
- }
-}
-\f
/* 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
}
/* 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);
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,
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 *);
\f
/* Initialize the association of GNAT nodes to GCC trees. */
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.
!= 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);
}
\f
/* 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);
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);
{
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 ();
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;
return gnat_build_constructor (template_type, nreverse (template_elts));
}
\f
-/* 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)
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
- ("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 ("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. */
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)
{
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)
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)
{
/* 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);
/* 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);
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. */
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;
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;
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));
}
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
OSDN Git Service
