are in an exception handler. Not used in the zero-cost case. */
static GTY(()) VEC(tree,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 bool set_end_locus_from_node (tree, Node_Id);
static void set_gnu_expr_location_from_node (tree, Node_Id);
static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
-static tree build_raise_check (int, tree, enum exception_info_kind);
+static tree build_raise_check (int, enum exception_info_kind);
+static tree create_init_temporary (const char *, tree, tree *, Node_Id);
/* Hooks for debug info back-ends, only supported and used in a restricted set
of configurations. */
Entity_Id standard_exception_type, Int gigi_operating_mode)
{
Entity_Id gnat_literal;
- tree long_long_float_type, exception_type, t;
+ tree long_long_float_type, exception_type, t, ftype;
tree int64_type = gnat_type_for_size (64, 0);
struct elab_info *info;
int i;
DECL_IGNORED_P (t) = 1;
save_gnu_tree (gnat_literal, t, false);
- void_ftype = build_function_type (void_type_node, NULL_TREE);
+ void_ftype = build_function_type_list (void_type_node, NULL_TREE);
ptr_void_ftype = build_pointer_type (void_ftype);
/* Now declare run-time functions. */
- t = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
+ ftype = build_function_type_list (ptr_void_type_node, sizetype, NULL_TREE);
/* malloc is a function declaration tree for a function to allocate
memory. */
malloc_decl
= create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
- build_function_type (ptr_void_type_node,
- tree_cons (NULL_TREE,
- sizetype, t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ ftype, NULL_TREE, false, true, true, true, NULL,
+ Empty);
DECL_IS_MALLOC (malloc_decl) = 1;
/* malloc32 is a function declaration tree for a function to allocate
32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */
malloc32_decl
= create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
- build_function_type (ptr_void_type_node,
- tree_cons (NULL_TREE,
- sizetype, t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ ftype, NULL_TREE, false, true, true, true, NULL,
+ Empty);
DECL_IS_MALLOC (malloc32_decl) = 1;
/* free is a function declaration tree for a function to free memory. */
free_decl
= create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ build_function_type_list (void_type_node,
+ ptr_void_type_node,
+ NULL_TREE),
+ NULL_TREE, false, true, true, true, NULL, Empty);
/* This is used for 64-bit multiplication with overflow checking. */
mulv64_decl
= create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
build_function_type_list (int64_type, int64_type,
int64_type, NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
+ NULL_TREE, false, true, true, true, NULL, Empty);
/* Name of the _Parent field in tagged record types. */
parent_name_id = get_identifier (Get_Name_String (Name_uParent));
/* Functions to get and set the jumpbuf pointer for the current thread. */
get_jmpbuf_decl
= create_subprog_decl
- (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
- NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
+ (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
+ NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
+ NULL_TREE, false, true, true, true, NULL, Empty);
DECL_IGNORED_P (get_jmpbuf_decl) = 1;
set_jmpbuf_decl
= create_subprog_decl
- (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
- NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
+ NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
+ NULL_TREE),
+ NULL_TREE, false, true, true, true, NULL, Empty);
DECL_IGNORED_P (set_jmpbuf_decl) = 1;
/* setjmp returns an integer and has one operand, which is a pointer to
setjmp_decl
= create_subprog_decl
(get_identifier ("__builtin_setjmp"), NULL_TREE,
- build_function_type (integer_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ build_function_type_list (integer_type_node, jmpbuf_ptr_type,
+ NULL_TREE),
+ NULL_TREE, false, true, true, true, NULL, Empty);
DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
update_setjmp_buf_decl
= create_subprog_decl
(get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
+ NULL_TREE, false, true, true, true, NULL, Empty);
DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
/* Hooks to call when entering/leaving an exception handler. */
+ ftype
+ = build_function_type_list (void_type_node, ptr_void_type_node, NULL_TREE);
+
begin_handler_decl
= create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ ftype, NULL_TREE, false, true, true, true, NULL,
+ Empty);
DECL_IGNORED_P (begin_handler_decl) = 1;
end_handler_decl
= create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ ftype, NULL_TREE, false, true, true, true, NULL,
+ Empty);
DECL_IGNORED_P (end_handler_decl) = 1;
+ reraise_zcx_decl
+ = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
+ ftype, NULL_TREE, false, true, true, true, NULL,
+ Empty);
+ DECL_IGNORED_P (reraise_zcx_decl) = 1;
+
/* If in no exception handlers mode, all raise statements are redirected to
__gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
this procedure will never be called in this mode. */
tree decl
= create_subprog_decl
(get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type
- (unsigned_char_type_node),
- tree_cons (NULL_TREE,
- integer_type_node,
- t))),
- NULL_TREE, false, true, true, NULL, Empty);
+ build_function_type_list (void_type_node,
+ build_pointer_type
+ (unsigned_char_type_node),
+ integer_type_node, NULL_TREE),
+ NULL_TREE, false, true, true, true, NULL, Empty);
TREE_THIS_VOLATILE (decl) = 1;
TREE_SIDE_EFFECTS (decl) = 1;
TREE_TYPE (decl)
{
/* Otherwise, make one decl for each exception reason. */
for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
- gnat_raise_decls[i] = build_raise_check (i, t, exception_simple);
+ gnat_raise_decls[i] = build_raise_check (i, exception_simple);
for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
gnat_raise_decls_ext[i]
- = build_raise_check (i, t,
+ = build_raise_check (i,
i == CE_Index_Check_Failed
|| i == CE_Range_Check_Failed
|| i == CE_Invalid_Data
/* Make other functions used for exception processing. */
get_excptr_decl
= create_subprog_decl
- (get_identifier ("system__soft_links__get_gnat_exception"),
- NULL_TREE,
- build_function_type (build_pointer_type (except_type_node), NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
+ (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
+ build_function_type_list (build_pointer_type (except_type_node),
+ NULL_TREE),
+ NULL_TREE, false, true, true, true, NULL, Empty);
raise_nodefer_decl
= create_subprog_decl
(get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type (except_type_node),
- t)),
- NULL_TREE, false, true, true, NULL, Empty);
+ build_function_type_list (void_type_node,
+ build_pointer_type (except_type_node),
+ NULL_TREE),
+ NULL_TREE, false, true, true, true, NULL, Empty);
- /* Indicate that these never return. */
+ /* Indicate that it never returns. */
TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
TREE_TYPE (raise_nodefer_decl)
longest_float_type_node = TREE_TYPE (long_long_float_type);
/* Dummy objects to materialize "others" and "all others" in the exception
- tables. These are exported by a-exexpr.adb, so see this unit for the
- types to use. */
+ tables. These are exported by a-exexpr-gcc.adb, so see this unit for
+ the types to use. */
others_decl
= create_var_decl (get_identifier ("OTHERS"),
get_identifier ("__gnat_others_value"),
}
\f
/* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
- CHECK (if EXTENDED is false), or __gnat_rcheck_xx_ext (if EXTENDED is
- true). */
+ CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
static tree
-build_raise_check (int check, tree void_tree, enum exception_info_kind kind)
+build_raise_check (int check, enum exception_info_kind kind)
{
char name[21];
- tree result;
+ tree result, ftype;
- if (kind != exception_simple)
+ if (kind == exception_simple)
{
- sprintf (name, "__gnat_rcheck_%.2d_ext", check);
- result
- = create_subprog_decl
- (get_identifier (name), NULL_TREE,
- build_function_type
- (void_type_node,
- tree_cons
- (NULL_TREE, build_pointer_type (unsigned_char_type_node),
- tree_cons (NULL_TREE, integer_type_node,
- tree_cons (NULL_TREE, integer_type_node,
- kind == exception_column
- ? void_tree
- : tree_cons (NULL_TREE, integer_type_node,
- tree_cons (NULL_TREE,
- integer_type_node,
- void_tree)))))),
- NULL_TREE, false, true, true, NULL, Empty);
+ sprintf (name, "__gnat_rcheck_%.2d", check);
+ ftype
+ = build_function_type_list (void_type_node,
+ build_pointer_type
+ (unsigned_char_type_node),
+ integer_type_node, NULL_TREE);
}
else
{
- sprintf (name, "__gnat_rcheck_%.2d", check);
- result
- = create_subprog_decl
- (get_identifier (name), NULL_TREE,
- build_function_type
- (void_type_node,
- tree_cons
- (NULL_TREE, build_pointer_type (unsigned_char_type_node),
- tree_cons (NULL_TREE, integer_type_node, void_tree))),
- NULL_TREE, false, true, true, NULL, Empty);
+ tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
+ sprintf (name, "__gnat_rcheck_%.2d_ext", check);
+ ftype
+ = build_function_type_list (void_type_node,
+ build_pointer_type
+ (unsigned_char_type_node),
+ integer_type_node, integer_type_node,
+ t, t, NULL_TREE);
}
+ result
+ = create_subprog_decl (get_identifier (name), NULL_TREE, ftype, NULL_TREE,
+ false, true, true, true, NULL, Empty);
+
+ /* Indicate that it never returns. */
TREE_THIS_VOLATILE (result) = 1;
TREE_SIDE_EFFECTS (result) = 1;
TREE_TYPE (result)
case Attr_First_Bit:
case Attr_Last_Bit:
case Attr_Bit:
+ case Attr_Asm_Input:
+ case Attr_Asm_Output:
default:
return 1;
}
attribute Position, generated for dispatching code (see Make_DT in
exp_disp,adb). In that case we need the type itself, not is parent,
in particular if it is a derived type */
- if (Is_Private_Type (gnat_temp_type)
- && Has_Unknown_Discriminants (gnat_temp_type)
- && Ekind (gnat_temp) == E_Constant
+ if (Ekind (gnat_temp) == E_Constant
+ && Is_Private_Type (gnat_temp_type)
+ && (Has_Unknown_Discriminants (gnat_temp_type)
+ || (Present (Full_View (gnat_temp_type))
+ && Has_Discriminants (Full_View (gnat_temp_type))))
&& Present (Full_View (gnat_temp)))
{
gnat_temp = Full_View (gnat_temp);
&& DECL_BY_COMPONENT_PTR_P (gnu_result))))
{
const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
- tree renamed_obj;
+ /* First do the first dereference if needed. */
if (TREE_CODE (gnu_result) == PARM_DECL
&& DECL_BY_DOUBLE_REF_P (gnu_result))
{
TREE_THIS_NOTRAP (gnu_result) = 1;
}
+ /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
if (TREE_CODE (gnu_result) == PARM_DECL
&& DECL_BY_COMPONENT_PTR_P (gnu_result))
- {
- gnu_result
- = build_unary_op (INDIRECT_REF, NULL_TREE,
- convert (build_pointer_type (gnu_result_type),
- gnu_result));
- if (TREE_CODE (gnu_result) == INDIRECT_REF)
- TREE_THIS_NOTRAP (gnu_result) = 1;
- }
+ gnu_result
+ = 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)
+ gnu_result = DECL_INITIAL (gnu_result);
/* If it's a renaming pointer and we are at the right binding level,
we can reference the renamed object directly, since the renamed
expression has been protected against multiple evaluations. */
- else if (TREE_CODE (gnu_result) == VAR_DECL
- && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result))
- && (!DECL_RENAMING_GLOBAL_P (gnu_result)
- || global_bindings_p ()))
- gnu_result = renamed_obj;
-
- /* Return the underlying CST for a CONST_DECL like a few lines below,
- after dereferencing in this case. */
- else if (TREE_CODE (gnu_result) == CONST_DECL)
- gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
- DECL_INITIAL (gnu_result));
+ if (TREE_CODE (gnu_result) == VAR_DECL
+ && DECL_RENAMED_OBJECT (gnu_result)
+ && (!DECL_RENAMING_GLOBAL_P (gnu_result) || global_bindings_p ()))
+ gnu_result = DECL_RENAMED_OBJECT (gnu_result);
+ /* Otherwise, do the final dereference. */
else
{
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
- if (TREE_CODE (gnu_result) == INDIRECT_REF)
+
+ if ((TREE_CODE (gnu_result) == INDIRECT_REF
+ || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
+ && No (Address_Clause (gnat_temp)))
TREE_THIS_NOTRAP (gnu_result) = 1;
- }
- if (read_only)
- TREE_READONLY (gnu_result) = 1;
+ if (read_only)
+ TREE_READONLY (gnu_result) = 1;
+ }
}
/* The GNAT tree has the type of a function as the type of its result. Also
/* 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. */
+ elaboration code if this identifier is used as an initializer itself.
+ Don't do it for aggregate types that contain a placeholder since their
+ initializers cannot be manipulated easily. */
if (TREE_CONSTANT (gnu_result)
&& DECL_P (gnu_result)
- && DECL_INITIAL (gnu_result))
+ && DECL_INITIAL (gnu_result)
+ && !(AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
+ && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_result))
+ && type_contains_placeholder_p (TREE_TYPE (gnu_result))))
{
bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
&& !DECL_CONST_CORRESPONDING_VAR (gnu_result));
/* Make sure any implicit dereference gets done. */
gnu_prefix = maybe_implicit_deref (gnu_prefix);
gnu_prefix = maybe_unconstrained_array (gnu_prefix);
+
/* We treat unconstrained array In parameters specially. */
- if (Nkind (Prefix (gnat_node)) == N_Identifier
- && !Is_Constrained (Etype (Prefix (gnat_node)))
- && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
- gnat_param = Entity (Prefix (gnat_node));
+ if (!Is_Constrained (Etype (Prefix (gnat_node))))
+ {
+ Node_Id gnat_prefix = Prefix (gnat_node);
+
+ /* This is the direct case. */
+ if (Nkind (gnat_prefix) == N_Identifier
+ && Ekind (Entity (gnat_prefix)) == E_In_Parameter)
+ gnat_param = Entity (gnat_prefix);
+
+ /* This is the indirect case. Note that we need to be sure that
+ the access value cannot be null as we'll hoist the load. */
+ if (Nkind (gnat_prefix) == N_Explicit_Dereference
+ && Nkind (Prefix (gnat_prefix)) == N_Identifier
+ && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter
+ && Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
+ gnat_param = Entity (Prefix (gnat_prefix));
+ }
+
gnu_type = TREE_TYPE (gnu_prefix);
prefix_unused = true;
gnu_result_type = get_unpadded_type (Etype (gnat_node));
prefix_unused = true;
break;
+ case Attr_Descriptor_Size:
+ 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. */
+ 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_type = get_unpadded_type (Etype (gnat_node));
+ prefix_unused = true;
+ break;
+
case Attr_Null_Parameter:
/* This is just a zero cast to the pointer type for our prefix and
dereferenced. */
if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
&& (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
{
- add_stmt_with_node (build3
- (CASE_LABEL_EXPR, void_type_node,
- gnu_low, gnu_high,
+ add_stmt_with_node (build_case_label
+ (gnu_low, gnu_high,
create_artificial_label (input_location)),
gnat_choice);
choices_added_p = true;
tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, 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 gnu_cond_expr = NULL_TREE, gnu_result;
/* Set location information for statement and end label. */
set_expr_location_from_node (gnu_loop_stmt, gnat_node);
tree gnu_high = TYPE_MAX_VALUE (gnu_type);
tree gnu_base_type = get_base_type (gnu_type);
tree gnu_one_node = convert (gnu_base_type, integer_one_node);
- tree gnu_first, gnu_last;
+ tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
enum tree_code update_code, test_code, shift_code;
- bool reverse = Reverse_Present (gnat_loop_spec), fallback = false;
+ bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
/* We must disable modulo reduction for the iteration variable, if any,
in order for the loop comparison to be effective. */
/* We use two different strategies to translate the loop, depending on
whether optimization is enabled.
- If it is, we try to generate the canonical form of loop expected by
- the loop optimizer, which is the do-while form:
+ If it is, we generate the canonical loop form expected by the loop
+ optimizer and the loop vectorizer, which is the do-while form:
ENTRY_COND
loop:
BOTTOM_COND
GOTO loop
- This makes it possible to bypass loop header copying and to turn the
- BOTTOM_COND into an inequality test. This should catch (almost) all
- loops with constant starting point. If we cannot, we try to generate
- the default form, which is:
+ This avoids an implicit dependency on loop header copying and makes
+ it possible to turn BOTTOM_COND into an inequality test.
+
+ If optimization is disabled, loop header copying doesn't come into
+ play and we try to generate the loop form with the fewer conditional
+ branches. First, the default form, which is:
loop:
TOP_COND
BOTTOM_UPDATE
GOTO loop
- It will be rotated during loop header copying and an entry test added
- to yield the do-while form. This should catch (almost) all loops with
- constant ending point. If we cannot, we generate the fallback form:
+ It should catch most loops with constant ending point. Then, if we
+ cannot, we try to generate the shifted form:
- ENTRY_COND
loop:
+ TOP_COND
+ TOP_UPDATE
BODY
- BOTTOM_COND
- BOTTOM_UPDATE
GOTO loop
- which works in all cases but for which loop header copying will copy
- the BOTTOM_COND, thus adding a third conditional branch.
-
- If optimization is disabled, loop header copying doesn't come into
- play and we try to generate the loop forms with the less conditional
- branches directly. First, the default form, it should catch (almost)
- all loops with constant ending point. Then, if we cannot, we try to
- generate the shifted form:
+ which should catch loops with constant starting point. Otherwise, if
+ we cannot, we generate the fallback form:
+ ENTRY_COND
loop:
- TOP_COND
- TOP_UPDATE
BODY
+ BOTTOM_COND
+ BOTTOM_UPDATE
GOTO loop
- which should catch loops with constant starting point. Otherwise, if
- we cannot, we generate the fallback form. */
+ which works in all cases. */
if (optimize)
{
- /* We can use the do-while form if GNU_FIRST-1 doesn't overflow. */
+ /* We can use the do-while form directly if GNU_FIRST-1 doesn't
+ overflow. */
if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
- {
- gnu_first = build_binary_op (shift_code, gnu_base_type,
- gnu_first, gnu_one_node);
- LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
- LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
- }
-
- /* Otherwise, we can use the default form if GNU_LAST+1 doesn't. */
- else if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
;
- /* Otherwise, use the fallback form. */
+ /* Otherwise, use the do-while form with the help of a special
+ induction variable in the (unsigned version of) the base
+ type, in order to have wrap-around arithmetics for it. */
else
- fallback = true;
+ {
+ if (!TYPE_UNSIGNED (gnu_base_type))
+ {
+ gnu_base_type = gnat_unsigned_type (gnu_base_type);
+ gnu_first = convert (gnu_base_type, gnu_first);
+ gnu_last = convert (gnu_base_type, gnu_last);
+ gnu_one_node = convert (gnu_base_type, integer_one_node);
+ }
+ use_iv = true;
+ }
+
+ gnu_first
+ = build_binary_op (shift_code, gnu_base_type, gnu_first,
+ gnu_one_node);
+ LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
+ LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
}
else
{
else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
&& !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
{
- gnu_first = build_binary_op (shift_code, gnu_base_type,
- gnu_first, gnu_one_node);
- gnu_last = build_binary_op (shift_code, gnu_base_type,
- gnu_last, gnu_one_node);
+ gnu_first
+ = build_binary_op (shift_code, gnu_base_type, gnu_first,
+ gnu_one_node);
+ gnu_last
+ = build_binary_op (shift_code, gnu_base_type, gnu_last,
+ gnu_one_node);
LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
}
/* Otherwise, use the fallback form. */
else
- fallback = true;
+ LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
}
- if (fallback)
- LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
-
/* If we use the BOTTOM_COND, we can turn the test into an inequality
test but we may have to add ENTRY_COND to protect the empty loop. */
if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
start_stmt_group ();
gnat_pushlevel ();
+ /* If we use the special induction variable, create it and set it to
+ its initial value. Morever, the regular iteration variable cannot
+ itself be initialized, lest the initial value wrapped around. */
+ if (use_iv)
+ {
+ gnu_loop_iv
+ = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
+ add_stmt (gnu_stmt);
+ gnu_first = NULL_TREE;
+ }
+ else
+ gnu_loop_iv = NULL_TREE;
+
/* 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 = convert (gnu_base_type, gnu_loop_var);
/* Set either the top or bottom exit condition. */
- LOOP_STMT_COND (gnu_loop_stmt)
- = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
- gnu_last);
+ if (use_iv)
+ LOOP_STMT_COND (gnu_loop_stmt)
+ = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
+ gnu_last);
+ else
+ LOOP_STMT_COND (gnu_loop_stmt)
+ = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
+ gnu_last);
/* Set either the top or bottom update statement and give it the source
location of the iteration for better coverage info. */
- LOOP_STMT_UPDATE (gnu_loop_stmt)
- = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
- build_binary_op (update_code, gnu_base_type,
- gnu_loop_var, gnu_one_node));
- set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
- gnat_iter_scheme);
+ if (use_iv)
+ {
+ gnu_stmt
+ = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
+ build_binary_op (update_code, gnu_base_type,
+ gnu_loop_iv, gnu_one_node));
+ set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
+ append_to_statement_list (gnu_stmt,
+ &LOOP_STMT_UPDATE (gnu_loop_stmt));
+ gnu_stmt
+ = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
+ gnu_loop_iv);
+ set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
+ append_to_statement_list (gnu_stmt,
+ &LOOP_STMT_UPDATE (gnu_loop_stmt));
+ }
+ else
+ {
+ gnu_stmt
+ = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
+ build_binary_op (update_code, gnu_base_type,
+ gnu_loop_var, gnu_one_node));
+ set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
+ LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
+ }
}
/* If the loop was named, have the name point to this loop. In this case,
= 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". */
- if (gnu_loop_var)
+ /* If we have an iteration scheme, then we are in a statement group. Add
+ the LOOP_STMT to it, finish it and make it the "loop". */
+ if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
{
add_stmt (gnu_loop_stmt);
gnat_poplevel ();
ptr_void_type_node,
ptr_void_type_node,
NULL_TREE),
- NULL_TREE, 0, 1, 1, 0, Empty);
+ NULL_TREE, false, true, true, true, NULL,
+ Empty);
/* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */
DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
return;
establish_stmt
- = build_call_1_expr (vms_builtin_establish_handler_decl,
+ = build_call_n_expr (vms_builtin_establish_handler_decl, 1,
build_unary_op
(ADDR_EXPR, NULL_TREE,
gnat_vms_condition_handler_decl));
add_stmt (establish_stmt);
}
+
+/* Similar, but for RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR
+ around the assignment of RET_VAL to RET_OBJ. Otherwise just build a bare
+ RETURN_EXPR around RESULT_OBJ, which may be null in this case. */
+
+static tree
+build_return_expr (tree ret_obj, tree ret_val)
+{
+ tree result_expr;
+
+ if (ret_val)
+ {
+ /* The gimplifier explicitly enforces the following invariant:
+
+ RETURN_EXPR
+ |
+ MODIFY_EXPR
+ / \
+ / \
+ RET_OBJ ...
+
+ As a consequence, type consistency dictates that we use the type
+ of the RET_OBJ as the operation type. */
+ tree operation_type = TREE_TYPE (ret_obj);
+
+ /* Convert the right operand to the operation type. Note that it's the
+ same transformation as in the MODIFY_EXPR case of build_binary_op,
+ with the assumption that the type cannot involve a placeholder. */
+ if (operation_type != TREE_TYPE (ret_val))
+ ret_val = convert (operation_type, ret_val);
+
+ result_expr = build2 (MODIFY_EXPR, void_type_node, ret_obj, ret_val);
+ }
+ else
+ result_expr = ret_obj;
+
+ return build1 (RETURN_EXPR, void_type_node, result_expr);
+}
+
+/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
+ and the GNAT node GNAT_SUBPROG. */
+
+static void
+build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
+{
+ tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
+ tree gnu_subprog_param, gnu_stub_param, gnu_param;
+ tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
+ VEC(tree,gc) *gnu_param_vec = NULL;
+
+ gnu_subprog_type = TREE_TYPE (gnu_subprog);
+
+ /* Initialize the information structure for the function. */
+ allocate_struct_function (gnu_stub_decl, false);
+ set_cfun (NULL);
+
+ begin_subprog_body (gnu_stub_decl);
+
+ start_stmt_group ();
+ gnat_pushlevel ();
+
+ /* Loop over the parameters of the stub and translate any of them
+ passed by descriptor into a by reference one. */
+ for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
+ gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog);
+ gnu_stub_param;
+ gnu_stub_param = TREE_CHAIN (gnu_stub_param),
+ gnu_subprog_param = TREE_CHAIN (gnu_subprog_param))
+ {
+ if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
+ {
+ gcc_assert (DECL_BY_REF_P (gnu_subprog_param));
+ gnu_param
+ = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param),
+ gnu_stub_param,
+ DECL_PARM_ALT_TYPE (gnu_stub_param),
+ DECL_BY_DOUBLE_REF_P (gnu_subprog_param),
+ gnat_subprog);
+ }
+ else
+ gnu_param = gnu_stub_param;
+
+ VEC_safe_push (tree, gc, gnu_param_vec, gnu_param);
+ }
+
+ /* Invoke the internal subprogram. */
+ gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
+ gnu_subprog);
+ gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type),
+ gnu_subprog_addr, gnu_param_vec);
+
+ /* Propagate the return value, if any. */
+ if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
+ add_stmt (gnu_subprog_call);
+ else
+ add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl),
+ gnu_subprog_call));
+
+ gnat_poplevel ();
+ end_subprog_body (end_stmt_group ());
+}
\f
/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
don't return anything. */
/* The entry in the CI_CO_LIST that represents a function return, if any. */
tree gnu_return_var_elmt = NULL_TREE;
tree gnu_result;
+ struct language_function *gnu_subprog_language;
VEC(parm_attr,gc) *cache;
/* If this is a generic object or if it has been eliminated,
relayout_decl (gnu_result_decl);
}
- /* Propagate the debug mode. */
- if (!Needs_Debug_Info (gnat_subprog_id))
- DECL_IGNORED_P (gnu_subprog_decl) = 1;
-
/* Set the line number in the decl to correspond to that of the body so that
the line number notes are written correctly. */
Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
/* Initialize the information structure for the function. */
allocate_struct_function (gnu_subprog_decl, false);
- DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
- = ggc_alloc_cleared_language_function ();
+ gnu_subprog_language = ggc_alloc_cleared_language_function ();
+ DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
set_cfun (NULL);
begin_subprog_body (gnu_subprog_decl);
/* If we populated the parameter attributes cache, we need to make sure that
the cached expressions are evaluated on all the possible paths leading to
their uses. So we force their evaluation on entry of the function. */
- cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
+ cache = gnu_subprog_language->parm_attr_cache;
if (cache)
{
struct parm_attr_d *pa;
add_stmt (gnu_result);
gnu_result = end_stmt_group ();
+
+ gnu_subprog_language->parm_attr_cache = NULL;
}
/* If we are dealing with a return from an Ada procedure with parameters
VEC_pop (tree, gnu_return_label_stack);
- end_subprog_body (gnu_result);
-
/* 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
declaration tree. */
set_end_locus_from_node (gnu_result, gnat_node);
set_end_locus_from_node (gnu_subprog_decl, gnat_node);
+ end_subprog_body (gnu_result);
+
/* Finally annotate the parameters and disconnect the trees for parameters
that we have turned into variables since they are now unusable. */
for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
save_gnu_tree (gnat_param, NULL_TREE, false);
}
- if (DECL_FUNCTION_STUB (gnu_subprog_decl))
- build_function_stub (gnu_subprog_decl, gnat_subprog_id);
-
if (gnu_return_var_elmt)
TREE_VALUE (gnu_return_var_elmt) = void_type_node;
+ /* 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
tree gnu_formal = present_gnu_tree (gnat_formal)
? get_gnu_tree (gnat_formal) : NULL_TREE;
tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
+ const bool is_true_formal_parm
+ = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
/* In the Out or In Out case, we must suppress conversions that yield
an lvalue but can nevertheless cause the creation of a temporary,
because we need the real object in this case, either to pass its
We do it in the In case too, except for an unchecked conversion
because it alone can cause the actual to be misaligned and the
addressability test is applied to the real object. */
- bool suppress_type_conversion
+ const bool suppress_type_conversion
= ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
&& Ekind (gnat_formal) != E_In_Parameter)
|| (Nkind (gnat_actual) == N_Type_Conversion
/* If we are passing a non-addressable parameter by reference, pass the
address of a copy. In the Out or In Out case, set up to copy back
out after the call. */
- if (gnu_formal
+ if (is_true_formal_parm
&& (DECL_BY_REF_P (gnu_formal)
- || (TREE_CODE (gnu_formal) == PARM_DECL
- && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
- || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
+ || DECL_BY_COMPONENT_PTR_P (gnu_formal)
+ || DECL_BY_DESCRIPTOR_P (gnu_formal))
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
&& !addressable_p (gnu_name, gnu_name_type))
{
/* If we have not saved a GCC object for the formal, it means it is an
Out parameter not passed by reference and that need not be copied in.
Otherwise, first see if the parameter is passed by reference. */
- if (gnu_formal
- && TREE_CODE (gnu_formal) == PARM_DECL
- && DECL_BY_REF_P (gnu_formal))
+ if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
{
if (Ekind (gnat_formal) != E_In_Parameter)
{
/* There is no need to convert the actual to the formal's type before
taking its address. The only exception is for unconstrained array
types because of the way we build fat pointers. */
- else if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
- gnu_actual = convert (gnu_formal_type, gnu_actual);
+ if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
+ {
+ /* Put back a view conversion for In Out or Out parameters. */
+ if (Ekind (gnat_formal) != E_In_Parameter)
+ gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
+ gnu_actual);
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
+ }
/* The symmetry of the paths to the type of an entity is broken here
since arguments don't know that they will be passed by ref. */
- gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
+ gnu_formal_type = TREE_TYPE (gnu_formal);
if (DECL_BY_DOUBLE_REF_P (gnu_formal))
gnu_actual
gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
}
- else if (gnu_formal
- && TREE_CODE (gnu_formal) == PARM_DECL
- && DECL_BY_COMPONENT_PTR_P (gnu_formal))
+ else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
{
- gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
+ gnu_formal_type = TREE_TYPE (gnu_formal);
gnu_actual = maybe_implicit_deref (gnu_actual);
gnu_actual = maybe_unconstrained_array (gnu_actual);
but this is the most likely to work in all cases. */
gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
}
- else if (gnu_formal
- && TREE_CODE (gnu_formal) == PARM_DECL
- && DECL_BY_DESCRIPTOR_P (gnu_formal))
+ else if (is_true_formal_parm && DECL_BY_DESCRIPTOR_P (gnu_formal))
{
gnu_actual = convert (gnu_formal_type, gnu_actual);
if (Ekind (gnat_formal) != E_In_Parameter)
gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
- if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
+ if (!is_true_formal_parm)
{
/* Make sure side-effects are evaluated before the call. */
if (TREE_SIDE_EFFECTS (gnu_name))
the setjmp buf known for any decls in this block. */
if (setjmp_longjmp)
{
- gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
- NULL_TREE, jmpbuf_ptr_type,
- build_call_0_expr (get_jmpbuf_decl),
- false, false, false, false,
- NULL, gnat_node);
+ gnu_jmpsave_decl
+ = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
+ jmpbuf_ptr_type,
+ build_call_n_expr (get_jmpbuf_decl, 0),
+ false, false, false, false, NULL, gnat_node);
DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
/* The __builtin_setjmp receivers will immediately reinstall it. Now
might be forward edges going to __builtin_setjmp receivers on which
it is uninitialized, although they will never be actually taken. */
TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
- gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
- NULL_TREE, jmpbuf_type, NULL_TREE,
- false, false, false, false,
- NULL, gnat_node);
+ gnu_jmpbuf_decl
+ = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
+ jmpbuf_type,
+ NULL_TREE,
+ false, false, false, false, NULL, gnat_node);
DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
set_block_jmpbuf_decl (gnu_jmpbuf_decl);
/* When we exit this block, restore the saved value. */
- add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
+ add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
End_Label (gnat_node));
}
to the binding level we made above. Note that add_cleanup is FIFO
so we must register this cleanup after the EH cleanup just above. */
if (at_end)
- add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
+ add_cleanup (build_call_n_expr (gnat_to_gnu (At_End_Proc (gnat_node)), 0),
End_Label (gnat_node));
/* Now build the tree for the declarations and statements inside this block.
start_stmt_group ();
if (setjmp_longjmp)
- add_stmt (build_call_1_expr (set_jmpbuf_decl,
+ add_stmt (build_call_n_expr (set_jmpbuf_decl, 1,
build_unary_op (ADDR_EXPR, NULL_TREE,
gnu_jmpbuf_decl)));
VEC_safe_push (tree, gc, gnu_except_ptr_stack,
create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
build_pointer_type (except_type_node),
- build_call_0_expr (get_excptr_decl),
+ build_call_n_expr (get_excptr_decl, 0),
false, false, false, false,
NULL, gnat_node));
/* If none of the exception handlers did anything, re-raise but do not
defer abortion. */
- gnu_expr = build_call_1_expr (raise_nodefer_decl,
+ gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
VEC_last (tree, gnu_except_ptr_stack));
set_expr_location_from_node
(gnu_expr,
/* If the setjmp returns 1, we restore our incoming longjmp value and
then check the handlers. */
start_stmt_group ();
- add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
+ add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1,
gnu_jmpsave_decl),
gnat_node);
add_stmt (gnu_handler);
/* This block is now "if (setjmp) ... <handlers> else <block>". */
gnu_result = build3 (COND_EXPR, void_type_node,
- (build_call_1_expr
- (setjmp_decl,
+ (build_call_n_expr
+ (setjmp_decl, 1,
build_unary_op (ADDR_EXPR, NULL_TREE,
gnu_jmpbuf_decl))),
gnu_handler, gnu_inner_block);
an "if" statement to select the proper exceptions. For "Others", exclude
exceptions where Handled_By_Others is nonzero unless the All_Others flag
is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
- tree gnu_choice = integer_zero_node;
+ tree gnu_choice = boolean_false_node;
tree gnu_body = build_stmt_group (Statements (gnat_node), false);
Node_Id gnat_temp;
if (Nkind (gnat_temp) == N_Others_Choice)
{
if (All_Others (gnat_temp))
- this_choice = integer_one_node;
+ this_choice = boolean_true_node;
else
this_choice
= build_binary_op
tree gnu_expr;
tree gnu_etype;
tree gnu_current_exc_ptr;
- tree gnu_incoming_exc_ptr;
+ tree prev_gnu_incoming_exc_ptr;
Node_Id gnat_temp;
/* We build a TREE_LIST of nodes representing what exception types this
gnu_current_exc_ptr
= build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
1, integer_zero_node);
+ prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
ptr_type_node, gnu_current_exc_ptr,
false, false, false, false,
NULL, gnat_node);
- add_stmt_with_node (build_call_1_expr (begin_handler_decl,
+ add_stmt_with_node (build_call_n_expr (begin_handler_decl, 1,
gnu_incoming_exc_ptr),
gnat_node);
/* ??? We don't seem to have an End_Label at hand to set the location. */
- add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
+ add_cleanup (build_call_n_expr (end_handler_decl, 1, gnu_incoming_exc_ptr),
Empty);
add_stmt_list (Statements (gnat_node));
gnat_poplevel ();
+ gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
+
return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
end_stmt_group ());
}
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);
+ NULL_TREE, void_ftype, NULL_TREE, false, true, false, true, NULL,
+ gnat_unit);
struct elab_info *info;
VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl);
Get_String_Char (gnat_string, i + 1));
CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
- gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
- 0);
+ gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node);
}
gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
(Entity (Prefix (gnat_node)),
attr == Attr_Elab_Body ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, false,
- true, true, NULL, gnat_node);
+ true, true, true, NULL, gnat_node);
gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
}
case N_Return_Statement:
{
- tree gnu_ret_val, gnu_ret_obj;
+ tree gnu_ret_obj, gnu_ret_val;
/* If the subprogram is a function, we must return the expression. */
if (Present (Expression (gnat_node)))
{
tree gnu_subprog_type = TREE_TYPE (current_function_decl);
- tree gnu_ret_type = TREE_TYPE (gnu_subprog_type);
- tree gnu_result_decl = DECL_RESULT (current_function_decl);
- gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
/* If this function has copy-in/copy-out parameters, get the real
- variable and type for the return. See Subprogram_to_gnu. */
+ object for the return. See Subprogram_to_gnu. */
if (TYPE_CI_CO_LIST (gnu_subprog_type))
- {
- gnu_result_decl = VEC_last (tree, gnu_return_var_stack);
- gnu_ret_type = TREE_TYPE (gnu_result_decl);
- }
+ gnu_ret_obj = VEC_last (tree, gnu_return_var_stack);
+ else
+ gnu_ret_obj = DECL_RESULT (current_function_decl);
+
+ /* Get the GCC tree for the expression to be returned. */
+ gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
/* Do not remove the padding from GNU_RET_VAL if the inner type is
self-referential since we want to allocate the fixed size. */
(TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
- /* If the subprogram returns by direct reference, return a pointer
+ /* If the function returns by direct reference, return a pointer
to the return value. */
if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
|| By_Ref (gnat_node))
{
gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
- gnu_ret_val, gnu_ret_type,
+ gnu_ret_val,
+ TREE_TYPE (gnu_ret_obj),
Procedure_To_Call (gnat_node),
Storage_Pool (gnat_node),
gnat_node, false);
}
- /* If the subprogram returns by invisible reference, dereference
+ /* If the function returns by invisible reference, dereference
the pointer it is passed using the type of the return value
and build the copy operation manually. This ensures that we
don't copy too much data, for example if the return type is
unconstrained with a maximum size. */
if (TREE_ADDRESSABLE (gnu_subprog_type))
{
- gnu_ret_obj
+ tree gnu_ret_deref
= build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
- gnu_result_decl);
+ gnu_ret_obj);
gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_ret_obj, gnu_ret_val);
+ gnu_ret_deref, gnu_ret_val);
add_stmt_with_node (gnu_result, gnat_node);
gnu_ret_val = NULL_TREE;
- gnu_ret_obj = gnu_result_decl;
}
-
- /* Otherwise, build a regular return. */
- else
- gnu_ret_obj = gnu_result_decl;
}
else
{
- gnu_ret_val = NULL_TREE;
gnu_ret_obj = NULL_TREE;
+ gnu_ret_val = NULL_TREE;
}
/* If we have a return label defined, convert this into a branch to
gnu_result = build1 (GOTO_EXPR, void_type_node,
VEC_last (tree, gnu_return_label_stack));
+
/* 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;
- break;
}
- gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
+ /* Otherwise, build a regular return. */
+ else
+ gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
}
break;
gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
else
gcc_unreachable ();
+ break;
+
+ case N_Raise_Statement:
+ /* Only for reraise in back-end exceptions mode. */
+ gcc_assert (No (Name (gnat_node))
+ && Exception_Mechanism == Back_End_Exceptions);
+ start_stmt_group ();
+ gnat_pushlevel ();
+
+ /* Clear the current exception pointer so that the occurrence won't be
+ deallocated. */
+ gnu_expr = create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE,
+ ptr_type_node, gnu_incoming_exc_ptr,
+ false, false, false, false, NULL, gnat_node);
+
+ add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr,
+ convert (ptr_type_node, integer_zero_node)));
+ add_stmt (build_call_n_expr (reraise_zcx_decl, 1, gnu_expr));
+ gnat_poplevel ();
+ gnu_result = end_stmt_group ();
break;
case N_Push_Constraint_Error_Label:
mark it addressable. Note that we don't test
allows_mem like in the input case below; this
is modelled on the C front-end. */
- if (!allows_reg
- && !gnat_mark_addressable (output))
- output = error_mark_node;
+ if (!allows_reg)
+ {
+ STRIP_NOPS (output);
+ if (TREE_CODE (output) == CONST_DECL
+ && DECL_CONST_CORRESPONDING_VAR (output))
+ output = DECL_CONST_CORRESPONDING_VAR (output);
+ if (!gnat_mark_addressable (output))
+ output = error_mark_node;
+ }
}
else
output = error_mark_node;
{
/* If the operand is going to end up in memory,
mark it addressable. */
- if (!allows_reg && allows_mem
- && !gnat_mark_addressable (input))
- input = error_mark_node;
+ if (!allows_reg && allows_mem)
+ {
+ STRIP_NOPS (input);
+ if (TREE_CODE (input) == CONST_DECL
+ && DECL_CONST_CORRESPONDING_VAR (input))
+ input = DECL_CONST_CORRESPONDING_VAR (input);
+ if (!gnat_mark_addressable (input))
+ input = error_mark_node;
+ }
}
else
input = error_mark_node;
{
const int reason = UI_To_Int (Reason (gnat_node));
const Node_Id cond = Condition (gnat_node);
- bool handled = false;
if (type_annotate_only)
{
if (Exception_Extra_Info
&& !No_Exception_Handlers_Set ()
&& !get_exception_label (kind)
- && TREE_CODE (gnu_result_type) == VOID_TYPE
+ && VOID_TYPE_P (gnu_result_type)
&& Present (cond))
- {
- if (reason == CE_Access_Check_Failed)
- {
- gnu_result = build_call_raise_column (reason, gnat_node);
- handled = true;
- }
- else if ((reason == CE_Index_Check_Failed
- || reason == CE_Range_Check_Failed
- || reason == CE_Invalid_Data)
- && Nkind (cond) == N_Op_Not
- && Nkind (Right_Opnd (cond)) == N_In
- && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range)
- {
- Node_Id op = Right_Opnd (cond); /* N_In node */
- Node_Id index = Left_Opnd (op);
- Node_Id type = Etype (index);
+ switch (reason)
+ {
+ case CE_Access_Check_Failed:
+ gnu_result = build_call_raise_column (reason, gnat_node);
+ break;
- if (Is_Type (type)
- && Known_Esize (type)
- && UI_To_Int (Esize (type)) <= 32)
- {
- Node_Id right_op = Right_Opnd (op);
+ case CE_Index_Check_Failed:
+ case CE_Range_Check_Failed:
+ case CE_Invalid_Data:
+ if (Nkind (cond) == N_Op_Not
+ && Nkind (Right_Opnd (cond)) == N_In
+ && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range)
+ {
+ Node_Id op = Right_Opnd (cond); /* N_In node */
+ Node_Id index = Left_Opnd (op);
+ Node_Id range = Right_Opnd (op);
+ Node_Id type = Etype (index);
+ if (Is_Type (type)
+ && Known_Esize (type)
+ && UI_To_Int (Esize (type)) <= 32)
gnu_result
- = build_call_raise_range
- (reason, gnat_node,
- gnat_to_gnu (index), /* index */
- gnat_to_gnu (Low_Bound (right_op)), /* first */
- gnat_to_gnu (High_Bound (right_op))); /* last */
- handled = true;
- }
- }
+ = build_call_raise_range (reason, gnat_node,
+ gnat_to_gnu (index),
+ gnat_to_gnu
+ (Low_Bound (range)),
+ gnat_to_gnu
+ (High_Bound (range)));
+ }
+ break;
+
+ default:
+ break;
}
- if (handled)
+ 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))
{
- set_expr_location_from_node (gnu_result, gnat_node);
- gnu_result = build3 (COND_EXPR, void_type_node,
- gnat_to_gnu (cond),
- gnu_result, alloc_stmt_list ());
+ if (Present (cond))
+ gnu_result
+ = build3 (COND_EXPR, void_type_node, gnat_to_gnu (cond),
+ gnu_result, alloc_stmt_list ());
}
else
- {
- gnu_result = build_call_raise (reason, gnat_node, kind);
-
- /* 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 (TREE_CODE (gnu_result_type) == VOID_TYPE)
- {
- set_expr_location_from_node (gnu_result, gnat_node);
- if (Present (cond))
- gnu_result = build3 (COND_EXPR, void_type_node,
- gnat_to_gnu (cond),
- gnu_result, alloc_stmt_list ());
- }
- else
- gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
- }
+ gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
}
break;
return GS_UNHANDLED;
+ case VIEW_CONVERT_EXPR:
+ op = TREE_OPERAND (expr, 0);
+
+ /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
+ type to a scalar one, explicitly create the local temporary. That's
+ required if the type is passed by reference. */
+ if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
+ && AGGREGATE_TYPE_P (TREE_TYPE (op))
+ && !AGGREGATE_TYPE_P (TREE_TYPE (expr)))
+ {
+ tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
+ gimple_add_tmp_var (new_var);
+
+ mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
+ gimplify_and_add (mod, pre_p);
+
+ TREE_OPERAND (expr, 0) = new_var;
+ return GS_OK;
+ }
+
+ return GS_UNHANDLED;
+
case DECL_EXPR:
op = DECL_EXPR_DECL (expr);
{
tree int_64 = gnat_type_for_size (64, 0);
- return convert (gnu_type, build_call_2_expr (mulv64_decl,
+ return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
convert (int_64, lhs),
convert (int_64, rhs)));
}
{
/* Ensure GNU_EXPR only gets evaluated once. */
tree gnu_input = gnat_protect_expr (gnu_result);
- tree gnu_cond = integer_zero_node;
+ tree gnu_cond = boolean_false_node;
tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
}
}
\f
-/* GNAT_ENTITY is the type of the resulting constructors,
- GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
- and GNU_TYPE is the GCC type of the corresponding record.
-
- Return a CONSTRUCTOR to build the record. */
+/* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
+ front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
+ GCC type of the corresponding record type. Return the CONSTRUCTOR. */
static tree
assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
{
- tree gnu_list, gnu_result;
+ tree gnu_list = NULL_TREE, gnu_result;
/* We test for GNU_FIELD being empty in the case where a variant
was the last thing since we don't take things off GNAT_ASSOC in
that case. We check GNAT_ASSOC in case we have a variant, but it
has no fields. */
- for (gnu_list = NULL_TREE; Present (gnat_assoc);
- gnat_assoc = Next (gnat_assoc))
+ for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
{
Node_Id gnat_field = First (Choices (gnat_assoc));
tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
continue;
/* Also ignore discriminants of Unchecked_Unions. */
- else if (Is_Unchecked_Union (gnat_entity)
- && Ekind (Entity (gnat_field)) == E_Discriminant)
+ if (Is_Unchecked_Union (gnat_entity)
+ && Ekind (Entity (gnat_field)) == E_Discriminant)
continue;
/* Before assigning a value in an aggregate make sure range checks
gnu_result = extract_values (gnu_list, gnu_type);
#ifdef ENABLE_CHECKING
- {
- tree gnu_field;
-
- /* Verify every entry in GNU_LIST was used. */
- for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
- gcc_assert (TREE_ADDRESSABLE (gnu_field));
- }
+ /* Verify that every entry in GNU_LIST was used. */
+ for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
+ gcc_assert (TREE_ADDRESSABLE (gnu_list));
#endif
return gnu_result;
CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
convert (TREE_TYPE (gnu_array_type), gnu_expr));
- gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
+ gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node);
}
return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
OSDN Git Service
