static tree gnat_stabilize_reference (tree, bool);
static tree gnat_stabilize_reference_1 (tree, bool);
static void set_expr_location_from_node (tree, Node_Id);
-static int lvalue_required_p (Node_Id, tree, int);
+static int lvalue_required_p (Node_Id, tree, bool, bool);
/* Hooks for debug info back-ends, only supported and used in a restricted set
of configurations. */
/* Finally see if we have any elaboration procedures to deal with. */
for (info = elab_info_list; info; info = info->next)
{
- tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
- tree gnu_stmts;
+ tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
/* Unshare SAVE_EXPRs between subprograms. These are not unshared by
the gimplifier for obvious reasons, but it turns out that we need to
an upstream bug for which we would not change the outcome. */
walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL);
-
- /* We should have a BIND_EXPR, but it may or may not have any statements
- in it. If it doesn't have any, we have nothing to do. */
+ /* We should have a BIND_EXPR but it may not have any statements in it.
+ If it doesn't have any, we have nothing to do except for setting the
+ flag on the GNAT node. Otherwise, process the function as others. */
gnu_stmts = gnu_body;
if (TREE_CODE (gnu_stmts) == BIND_EXPR)
gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
-
- /* If there are no statements, there is no elaboration code. */
if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
- {
- Set_Has_No_Elaboration_Code (info->gnat_node, 1);
- }
+ Set_Has_No_Elaboration_Code (info->gnat_node, 1);
else
{
- /* Process the function as others. */
begin_subprog_body (info->elab_proc);
end_subprog_body (gnu_body);
}
\f
/* Return a positive value if an lvalue is required for GNAT_NODE.
GNU_TYPE is the type that will be used for GNAT_NODE in the
- translated GNU tree. ALIASED indicates whether the underlying
- object represented by GNAT_NODE is aliased in the Ada sense.
+ translated GNU tree. CONSTANT indicates whether the underlying
+ object represented by GNAT_NODE is constant in the Ada sense,
+ ALIASED whether it is aliased (but the latter doesn't affect
+ the outcome if CONSTANT is not true).
The function climbs up the GNAT tree starting from the node and
returns 1 upon encountering a node that effectively requires an
usage in non purely binary logic contexts. */
static int
-lvalue_required_p (Node_Id gnat_node, tree gnu_type, int aliased)
+lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
+ bool aliased)
{
Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
return id == Attr_Address
|| id == Attr_Access
|| id == Attr_Unchecked_Access
- || id == Attr_Unrestricted_Access;
+ || id == Attr_Unrestricted_Access
+ || id == Attr_Bit_Position
+ || id == Attr_Position
+ || id == Attr_First_Bit
+ || id == Attr_Last_Bit
+ || id == Attr_Bit;
}
case N_Parameter_Association:
return 0;
aliased |= Has_Aliased_Components (Etype (gnat_node));
- return lvalue_required_p (gnat_parent, gnu_type, aliased);
+ return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
case N_Selected_Component:
aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
- return lvalue_required_p (gnat_parent, gnu_type, aliased);
+ return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
case N_Object_Renaming_Declaration:
/* We need to make a real renaming only if the constant object is
optimize and return the rvalue. We make an exception if the object
is an identifier since in this case the rvalue can be propagated
attached to the CONST_DECL. */
- return (aliased != 0
+ return (!constant
+ || aliased
/* This should match the constant case of the renaming code. */
|| Is_Composite_Type
(Underlying_Type (Etype (Name (gnat_parent))))
case N_Assignment_Statement:
/* We cannot use a constructor if the LHS is an atomic object because
the actual assignment might end up being done component-wise. */
- return Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
- && Is_Atomic (Entity (Name (gnat_parent)));
+ return (Name (gnat_parent) == gnat_node
+ || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
+ && Is_Atomic (Entity (Name (gnat_parent)))));
default:
return 0;
&& !Is_Imported (gnat_temp)
&& Present (Address_Clause (gnat_temp)))
{
- require_lvalue = lvalue_required_p (gnat_node, gnu_result_type,
+ require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
Is_Aliased (gnat_temp));
use_constant_initializer = !require_lvalue;
}
the CST value if an lvalue is not required. Evaluate this
now if we have not already done so. */
if (object && require_lvalue < 0)
- require_lvalue = lvalue_required_p (gnat_node, gnu_result_type,
+ require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
Is_Aliased (gnat_temp));
if (!object || !require_lvalue)
asm_constraint = build_string (strlen (comment), comment);
free (comment);
#endif
- gnu_expr = build4 (ASM_EXPR, void_type_node,
+ gnu_expr = build5 (ASM_EXPR, void_type_node,
asm_constraint,
NULL_TREE,
tree_cons
(build_tree_list (NULL_TREE,
build_string (1, "g")),
gnu_expr, NULL_TREE),
- NULL_TREE);
+ NULL_TREE, NULL_TREE);
ASM_VOLATILE_P (gnu_expr) = 1;
set_expr_location_from_node (gnu_expr, gnat_node);
append_to_statement_list (gnu_expr, &gnu_result);
case Attr_Max_Size_In_Storage_Elements:
gnu_expr = gnu_prefix;
- /* Remove NOPs from GNU_EXPR and conversions from GNU_PREFIX.
- We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
- while (TREE_CODE (gnu_expr) == NOP_EXPR)
+ /* Remove NOPs and conversions between original and packable version
+ from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
+ to see if a COMPONENT_REF was involved. */
+ while (TREE_CODE (gnu_expr) == NOP_EXPR
+ || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
+ && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
+ == RECORD_TYPE
+ && TYPE_NAME (TREE_TYPE (gnu_expr))
+ == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
gnu_expr = TREE_OPERAND (gnu_expr, 0);
gnu_prefix = remove_conversions (gnu_prefix, true);
}
}
- /* If we are calling by supplying a pointer to a target, set up that
- pointer as the first argument. Use GNU_TARGET if one was passed;
- otherwise, make a target by building a variable of the maximum size
- of the type. */
+ /* If we are calling by supplying a pointer to a target, set up that pointer
+ as the first argument. Use GNU_TARGET if one was passed; otherwise, make
+ a target by building a variable and use the maximum size of the type if
+ it has self-referential size. */
if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
{
- tree gnu_real_ret_type
+ tree gnu_ret_type
= TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
if (!gnu_target)
{
- tree gnu_obj_type
- = maybe_pad_type (gnu_real_ret_type,
- max_size (TYPE_SIZE (gnu_real_ret_type), true),
- 0, Etype (Name (gnat_node)), "PAD", false,
- false, false);
+ tree gnu_obj_type;
+
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_ret_type)))
+ gnu_obj_type
+ = maybe_pad_type (gnu_ret_type,
+ max_size (TYPE_SIZE (gnu_ret_type), true),
+ 0, Etype (Name (gnat_node)), false, false,
+ false, true);
+ else
+ gnu_obj_type = gnu_ret_type;
/* ??? We may be about to create a static temporary if we happen to
be at the global binding level. That's a regression from what
gnu_actual_list
= tree_cons (NULL_TREE,
build_unary_op (ADDR_EXPR, NULL_TREE,
- unchecked_convert (gnu_real_ret_type,
+ unchecked_convert (gnu_ret_type,
gnu_target,
false)),
NULL_TREE);
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
&& !addressable_p (gnu_name, gnu_name_type))
{
- tree gnu_copy = gnu_name, gnu_temp;
+ tree gnu_copy = gnu_name;
/* If the type is by_reference, a copy is not allowed. */
if (Is_By_Reference_Type (Etype (gnat_formal)))
/* Set up to move the copy back to the original. */
if (Ekind (gnat_formal) != E_In_Parameter)
{
- gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy,
- gnu_name);
- set_expr_location_from_node (gnu_temp, gnat_node);
- append_to_statement_list (gnu_temp, &gnu_after_list);
+ tree stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy,
+ gnu_name);
+ set_expr_location_from_node (stmt, gnat_node);
+ append_to_statement_list (stmt, &gnu_after_list);
}
}
gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
}
+ /* Undo wrapping of boolean rvalues. */
+ if (TREE_CODE (gnu_actual) == NE_EXPR
+ && TREE_CODE (get_base_type (TREE_TYPE (gnu_actual)))
+ == BOOLEAN_TYPE
+ && integer_zerop (TREE_OPERAND (gnu_actual, 1)))
+ gnu_actual = TREE_OPERAND (gnu_actual, 0);
gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_actual, gnu_result);
set_expr_location_from_node (gnu_result, gnat_node);
a new occurrence on top of the stack, which means that this top does not
necessarily match the occurrence this handler was dealing with.
- The EXC_PTR_EXPR object references the exception occurrence being
+ __builtin_eh_pointer references the exception occurrence being
propagated. Upon handler entry, this is the exception for which the
handler is triggered. This might not be the case upon handler exit,
however, as we might have a new occurrence propagated by the handler's
We use a local variable to retrieve the incoming value at handler entry
time, and reuse it to feed the end_handler hook's argument at exit. */
- gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
+
+ gnu_current_exc_ptr
+ = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
+ 1, integer_zero_node);
gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
ptr_type_node, gnu_current_exc_ptr,
false, false, false, false, NULL,
return false;
}
-/* This function is the driver of the GNAT to GCC tree transformation
- process. It is the entry point of the tree transformer. GNAT_NODE is the
- root of some GNAT tree. Return the root of the corresponding GCC tree.
- If this is an expression, return the GCC equivalent of the expression. If
- it is a statement, return the statement. In the case when called for a
- statement, it may also add statements to the current statement group, in
- which case anything it returns is to be interpreted as occurring after
- anything `it already added. */
+/* This function is the driver of the GNAT to GCC tree transformation process.
+ It is the entry point of the tree transformer. GNAT_NODE is the root of
+ some GNAT tree. Return the root of the corresponding GCC tree. If this
+ is an expression, return the GCC equivalent of the expression. If this
+ is a statement, return the statement or add it to the current statement
+ group, in which case anything returned is to be interpreted as occurring
+ after anything added. */
tree
gnat_to_gnu (Node_Id gnat_node)
{
+ const Node_Kind kind = Nkind (gnat_node);
bool went_into_elab_proc = false;
tree gnu_result = error_mark_node; /* Default to no value. */
tree gnu_result_type = void_type_node;
- tree gnu_expr;
- tree gnu_lhs, gnu_rhs;
+ tree gnu_expr, gnu_lhs, gnu_rhs;
Node_Id gnat_temp;
/* Save node number for error message and set location information. */
error_gnat_node = gnat_node;
Sloc_to_locus (Sloc (gnat_node), &input_location);
- if (type_annotate_only
- && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call))
+ /* If this node is a statement and we are only annotating types, return an
+ empty statement list. */
+ if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
return alloc_stmt_list ();
- /* If this node is a non-static subexpression and we are only
- annotating types, make this into a NULL_EXPR. */
+ /* If this node is a non-static subexpression and we are only annotating
+ types, make this into a NULL_EXPR. */
if (type_annotate_only
- && IN (Nkind (gnat_node), N_Subexpr)
- && Nkind (gnat_node) != N_Identifier
+ && IN (kind, N_Subexpr)
+ && kind != N_Identifier
&& !Compile_Time_Known_Value (gnat_node))
return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
build_call_raise (CE_Range_Check_Failed, gnat_node,
N_Raise_Constraint_Error));
- /* If this is a Statement and we are at top level, it must be part of the
- elaboration procedure, so mark us as being in that procedure and push our
- context.
-
- If we are in the elaboration procedure, check if we are violating a
- No_Elaboration_Code restriction by having a statement there. */
- if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
- && Nkind (gnat_node) != N_Null_Statement)
- || Nkind (gnat_node) == N_Procedure_Call_Statement
- || Nkind (gnat_node) == N_Label
- || Nkind (gnat_node) == N_Implicit_Label_Declaration
- || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
- || ((Nkind (gnat_node) == N_Raise_Constraint_Error
- || Nkind (gnat_node) == N_Raise_Storage_Error
- || Nkind (gnat_node) == N_Raise_Program_Error)
- && (Ekind (Etype (gnat_node)) == E_Void)))
+ if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
+ && !IN (kind, N_SCIL_Node)
+ && kind != N_Null_Statement)
+ || kind == N_Procedure_Call_Statement
+ || kind == N_Label
+ || kind == N_Implicit_Label_Declaration
+ || kind == N_Handled_Sequence_Of_Statements
+ || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
{
+ /* If this is a statement and we are at top level, it must be part of
+ the elaboration procedure, so mark us as being in that procedure
+ and push our context. */
if (!current_function_decl)
{
current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
went_into_elab_proc = true;
}
- /* Don't check for a possible No_Elaboration_Code restriction violation
- on N_Handled_Sequence_Of_Statements, as we want to signal an error on
+ /* If we are in the elaboration procedure, check if we are violating a
+ No_Elaboration_Code restriction by having a statement there. Don't
+ check for a possible No_Elaboration_Code restriction violation on
+ N_Handled_Sequence_Of_Statements, as we want to signal an error on
every nested real statement instead. This also avoids triggering
spurious errors on dummy (empty) sequences created by the front-end
for package bodies in some cases. */
-
if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
- && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
+ && kind != N_Handled_Sequence_Of_Statements)
Check_Elaboration_Code_Allowed (gnat_node);
}
- switch (Nkind (gnat_node))
+ switch (kind)
{
/********************************/
/* Chapter 2: Lexical Elements */
break;
if (Present (Expression (gnat_node))
- && !(Nkind (gnat_node) == N_Object_Declaration
- && No_Initialization (gnat_node))
+ && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
&& (!type_annotate_only
|| Compile_Time_Known_Value (Expression (gnat_node))))
{
Node_Id *gnat_expr_array;
gnu_array_object = maybe_implicit_deref (gnu_array_object);
+
+ /* Convert vector inputs to their representative array type, to fit
+ what the code below expects. */
+ gnu_array_object = maybe_vector_array (gnu_array_object);
+
gnu_array_object = maybe_unconstrained_array (gnu_array_object);
/* If we got a padded type, remove it too. */
case N_Slice:
{
- tree gnu_type;
Node_Id gnat_range_node = Discrete_Range (gnat_node);
+ tree gnu_type;
gnu_result = gnat_to_gnu (Prefix (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* Simply return the naked low bound. */
gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
+ /* If this is a slice with non-constant size of an array with constant
+ size, set the maximum size for the allocation of temporaries. */
+ if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
+ && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
+ TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
+
gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
gnu_result, gnu_expr);
}
&& TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
gnu_aggr_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
+ else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
+ gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
if (Null_Record_Present (gnat_node))
gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
= convert_with_check (Etype (gnat_node), gnu_result,
Do_Overflow_Check (gnat_node),
Do_Range_Check (Expression (gnat_node)),
- Nkind (gnat_node) == N_Type_Conversion
+ kind == N_Type_Conversion
&& Float_Truncate (gnat_node), gnat_node);
break;
gnu_object, gnu_high));
}
- if (Nkind (gnat_node) == N_Not_In)
+ if (kind == N_Not_In)
gnu_result = invert_truthvalue (gnu_result);
}
break;
Modular_Integer_Kind))
{
enum tree_code code
- = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
- : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
+ = (kind == N_Op_Or ? BIT_IOR_EXPR
+ : kind == N_Op_And ? BIT_AND_EXPR
: BIT_XOR_EXPR);
gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
case N_Op_Shift_Right_Arithmetic:
case N_And_Then: case N_Or_Else:
{
- enum tree_code code = gnu_codes[Nkind (gnat_node)];
+ enum tree_code code = gnu_codes[kind];
bool ignore_lhs_overflow = false;
tree gnu_type;
gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ /* Pending generic support for efficient vector logical operations in
+ GCC, convert vectors to their representative array type view and
+ fallthrough. */
+ gnu_lhs = maybe_vector_array (gnu_lhs);
+ gnu_rhs = maybe_vector_array (gnu_rhs);
+
/* If this is a comparison operator, convert any references to
an unconstrained array value into a reference to the
actual array. */
/* If this is a shift whose count is not guaranteed to be correct,
we need to adjust the shift count. */
- if (IN (Nkind (gnat_node), N_Op_Shift)
- && !Shift_Count_OK (gnat_node))
+ if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
{
tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
tree gnu_max_shift
= convert (gnu_count_type, TYPE_SIZE (gnu_type));
- if (Nkind (gnat_node) == N_Op_Rotate_Left
- || Nkind (gnat_node) == N_Op_Rotate_Right)
+ if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
gnu_rhs, gnu_max_shift);
- else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
+ else if (kind == N_Op_Shift_Right_Arithmetic)
gnu_rhs
= build_binary_op
(MIN_EXPR, gnu_count_type,
so we may need to choose a different type. In this case,
we have to ignore integer overflow lest it propagates all
the way down and causes a CE to be explicitly raised. */
- if (Nkind (gnat_node) == N_Op_Shift_Right
- && !TYPE_UNSIGNED (gnu_type))
+ if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
{
gnu_type = gnat_unsigned_type (gnu_type);
ignore_lhs_overflow = true;
}
- else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
+ else if (kind == N_Op_Shift_Right_Arithmetic
&& TYPE_UNSIGNED (gnu_type))
{
gnu_type = gnat_signed_type (gnu_type);
do overflow checking, do it here. The goal is to push
the expansions further into the back end over time. */
if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
- && (Nkind (gnat_node) == N_Op_Add
- || Nkind (gnat_node) == N_Op_Subtract
- || Nkind (gnat_node) == N_Op_Multiply)
+ && (kind == N_Op_Add
+ || kind == N_Op_Subtract
+ || kind == N_Op_Multiply)
&& !TYPE_UNSIGNED (gnu_type)
&& !FLOAT_TYPE_P (gnu_type))
gnu_result = build_binary_op_trapv (code, gnu_type,
/* If this is a logical shift with the shift count not verified,
we must return zero if it is too large. We cannot compensate
above in this case. */
- if ((Nkind (gnat_node) == N_Op_Shift_Left
- || Nkind (gnat_node) == N_Op_Shift_Right)
+ if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
&& !Shift_Count_OK (gnat_node))
gnu_result
= build_cond_expr
= gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = build_cond_expr (gnu_result_type,
- gnat_truthvalue_conversion (gnu_cond),
- gnu_true, gnu_false);
+ gnu_result
+ = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
}
break;
&& !TYPE_UNSIGNED (gnu_result_type)
&& !FLOAT_TYPE_P (gnu_result_type))
gnu_result
- = build_unary_op_trapv (gnu_codes[Nkind (gnat_node)],
+ = build_unary_op_trapv (gnu_codes[kind],
gnu_result_type, gnu_expr, gnat_node);
else
- gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
+ gnu_result = build_unary_op (gnu_codes[kind],
gnu_result_type, gnu_expr);
break;
TREE_VALUE (tail) = input;
}
- gnu_result = build4 (ASM_EXPR, void_type_node,
+ gnu_result = build5 (ASM_EXPR, void_type_node,
gnu_template, gnu_outputs,
- gnu_inputs, gnu_clobbers);
+ gnu_inputs, gnu_clobbers, NULL_TREE);
ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
}
else
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result
- = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node,
- Nkind (gnat_node));
+ = build_call_raise (UI_To_Int (Reason (gnat_node)), 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
gnu_result = alloc_stmt_list ();
break;
+ case N_SCIL_Dispatch_Table_Object_Init:
+ case N_SCIL_Dispatch_Table_Tag_Init:
+ case N_SCIL_Dispatching_Call:
+ case N_SCIL_Tag_Init:
+ /* SCIL nodes require no processing for GCC. */
+ gnu_result = alloc_stmt_list ();
+ break;
+
case N_Raise_Statement:
case N_Function_Specification:
case N_Procedure_Specification:
/* Mark everything as used to prevent node sharing with subprograms.
Note that walk_tree knows how to deal with TYPE_DECL, but neither
VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
- mark_visited (&gnu_stmt);
+ MARK_VISITED (gnu_stmt);
if (TREE_CODE (gnu_decl) == VAR_DECL
|| TREE_CODE (gnu_decl) == CONST_DECL)
{
- mark_visited (&DECL_SIZE (gnu_decl));
- mark_visited (&DECL_SIZE_UNIT (gnu_decl));
- mark_visited (&DECL_INITIAL (gnu_decl));
+ MARK_VISITED (DECL_SIZE (gnu_decl));
+ MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
+ MARK_VISITED (DECL_INITIAL (gnu_decl));
}
-
- /* In any case, we have to deal with our own fields. */
- else if (TREE_CODE (gnu_decl) == TYPE_DECL)
- switch (TREE_CODE (type))
- {
- case RECORD_TYPE:
- case UNION_TYPE:
- case QUAL_UNION_TYPE:
- if ((t = TYPE_ADA_SIZE (type)))
- mark_visited (&t);
- break;
-
- case INTEGER_TYPE:
- case ENUMERAL_TYPE:
- case BOOLEAN_TYPE:
- case REAL_TYPE:
- if ((t = TYPE_RM_MIN_VALUE (type)))
- mark_visited (&t);
- if ((t = TYPE_RM_MAX_VALUE (type)))
- mark_visited (&t);
- break;
-
- default:
- break;
- }
}
else
add_stmt_with_node (gnu_stmt, gnat_entity);
static tree
mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
{
- if (TREE_VISITED (*tp))
+ tree t = *tp;
+
+ if (TREE_VISITED (t))
*walk_subtrees = 0;
/* Don't mark a dummy type as visited because we want to mark its sizes
and fields once it's filled in. */
- else if (!TYPE_IS_DUMMY_P (*tp))
- TREE_VISITED (*tp) = 1;
+ else if (!TYPE_IS_DUMMY_P (t))
+ TREE_VISITED (t) = 1;
- if (TYPE_P (*tp))
- TYPE_SIZES_GIMPLIFIED (*tp) = 1;
+ if (TYPE_P (t))
+ TYPE_SIZES_GIMPLIFIED (t) = 1;
return NULL_TREE;
}
+/* Mark nodes rooted at T with TREE_VISITED and types as having their
+ sized gimplified. We use this to indicate all variable sizes and
+ positions in global types may not be shared by any subprogram. */
+
+void
+mark_visited (tree t)
+{
+ walk_tree (&t, mark_visited_r, NULL, NULL);
+}
+
/* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */
static tree
return NULL_TREE;
}
-/* Mark nodes rooted at *TP with TREE_VISITED and types as having their
- sized gimplified. We use this to indicate all variable sizes and
- positions in global types may not be shared by any subprogram. */
-
-void
-mark_visited (tree *tp)
-{
- walk_tree (tp, mark_visited_r, NULL, NULL);
-}
-
/* Add GNU_CLEANUP, a cleanup action, to the current code group and
set its location to that of GNAT_NODE if present. */
case ADDR_EXPR:
op = TREE_OPERAND (expr, 0);
- /* If we're taking the address of a constant CONSTRUCTOR, force it to
+ /* If we are taking the address of a constant CONSTRUCTOR, force it to
be put into static memory. We know it's going to be readonly given
- the semantics we have and it's required to be static memory in
- the case when the reference is in an elaboration procedure. */
+ the semantics we have and it's required to be in static memory when
+ the reference is in an elaboration procedure. */
if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
{
tree new_var = create_tmp_var (TREE_TYPE (op), "C");
+ TREE_ADDRESSABLE (new_var) = 1;
TREE_READONLY (new_var) = 1;
TREE_STATIC (new_var) = 1;
- TREE_ADDRESSABLE (new_var) = 1;
DECL_INITIAL (new_var) = op;
TREE_OPERAND (expr, 0) = new_var;
return GS_ALL_DONE;
}
- /* If we are taking the address of a SAVE_EXPR, we are typically
- processing a misaligned argument to be passed by reference in a
- procedure call. We just mark the operand as addressable + not
- readonly here and let the common gimplifier code perform the
- temporary creation, initialization, and "instantiation" in place of
- the SAVE_EXPR in further operands, in particular in the copy back
- code inserted after the call. */
- else if (TREE_CODE (op) == SAVE_EXPR)
+ /* If we are taking the address of a SAVE_EXPR, we are typically dealing
+ with a misaligned argument to be passed by reference in a subprogram
+ call. We cannot let the common gimplifier code perform the creation
+ of the temporary and its initialization because, in order to ensure
+ that the final copy operation is a store and since the temporary made
+ for a SAVE_EXPR is not addressable, it may create another temporary,
+ addressable this time, which would break the back copy mechanism for
+ an IN OUT parameter. */
+ if (TREE_CODE (op) == SAVE_EXPR && !SAVE_EXPR_RESOLVED_P (op))
{
- TREE_ADDRESSABLE (op) = 1;
- TREE_READONLY (op) = 0;
- }
-
- /* We let the gimplifier process &COND_EXPR and expect it to yield the
- address of the selected operand when it is addressable. Besides, we
- also expect addressable_p to only let COND_EXPRs where both arms are
- addressable reach here. */
- else if (TREE_CODE (op) == COND_EXPR)
- ;
-
- /* Otherwise, if we are taking the address of something that is neither
- reference, declaration, or constant, make a variable for the operand
- here and then take its address. If we don't do it this way, we may
- confuse the gimplifier because it needs to know the variable is
- addressable at this point. This duplicates code in
- internal_get_tmp_var, which is unfortunate. */
- else if (TREE_CODE_CLASS (TREE_CODE (op)) != tcc_reference
- && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_declaration
- && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_constant)
- {
- tree new_var = create_tmp_var (TREE_TYPE (op), "A");
- gimple stmt;
-
+ tree mod, val = TREE_OPERAND (op, 0);
+ tree new_var = create_tmp_var (TREE_TYPE (op), "S");
TREE_ADDRESSABLE (new_var) = 1;
- stmt = gimplify_assign (new_var, op, pre_p);
- if (EXPR_HAS_LOCATION (op))
- gimple_set_location (stmt, EXPR_LOCATION (op));
+ mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, val);
+ if (EXPR_HAS_LOCATION (val))
+ SET_EXPR_LOCATION (mod, EXPR_LOCATION (val));
+ gimplify_and_add (mod, pre_p);
+ ggc_free (mod);
+
+ TREE_OPERAND (op, 0) = new_var;
+ SAVE_EXPR_RESOLVED_P (op) = 1;
TREE_OPERAND (expr, 0) = new_var;
recompute_tree_invariant_for_addr_expr (expr);
return GS_ALL_DONE;
}
+ return GS_UNHANDLED;
+
+ case DECL_EXPR:
+ op = DECL_EXPR_DECL (expr);
+
+ /* The expressions for the RM bounds must be gimplified to ensure that
+ they are properly elaborated. See gimplify_decl_expr. */
+ if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
+ && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
+ switch (TREE_CODE (TREE_TYPE (op)))
+ {
+ case INTEGER_TYPE:
+ case ENUMERAL_TYPE:
+ case BOOLEAN_TYPE:
+ case REAL_TYPE:
+ {
+ tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
+
+ val = TYPE_RM_MIN_VALUE (type);
+ if (val)
+ {
+ gimplify_one_sizepos (&val, pre_p);
+ for (t = type; t; t = TYPE_NEXT_VARIANT (t))
+ SET_TYPE_RM_MIN_VALUE (t, val);
+ }
+
+ val = TYPE_RM_MAX_VALUE (type);
+ if (val)
+ {
+ gimplify_one_sizepos (&val, pre_p);
+ for (t = type; t; t = TYPE_NEXT_VARIANT (t))
+ SET_TYPE_RM_MAX_VALUE (t, val);
+ }
+
+ }
+ break;
+
+ default:
+ break;
+ }
+
/* ... fall through ... */
default:
case UNCONSTRAINED_ARRAY_REF:
case INDIRECT_REF:
+ return true;
+
case CONSTRUCTOR:
case STRING_CST:
case INTEGER_CST:
case NULL_EXPR:
case SAVE_EXPR:
case CALL_EXPR:
+ case PLUS_EXPR:
+ case MINUS_EXPR:
+ /* All rvalues are deemed addressable since taking their address will
+ force a temporary to be created by the middle-end. */
return true;
case COND_EXPR:
OSDN Git Service
