* *
* C Implementation File *
* *
- * Copyright (C) 1992-2009, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2010, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
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. */
null_list = tree_cons (field, null_node, null_list);
}
- finish_record_type (fdesc_type_node, nreverse (field_list), 0, true);
+ finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
record_builtin_type ("descriptor", fdesc_type_node);
null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
}
error_gnat_node = Empty;
}
\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.
+/* 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.
+ 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
- lvalue downstream. It returns int instead of bool to facilitate
- usage in non purely binary logic contexts. */
+ The function climbs up the GNAT tree starting from the node and returns 1
+ upon encountering a node that effectively requires an lvalue downstream.
+ It returns int instead of bool to facilitate 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)))));
+
+ case N_Unchecked_Type_Conversion:
+ /* Returning 0 is very likely correct but we get better code if we
+ go through the conversion. */
+ return lvalue_required_p (gnat_parent,
+ get_unpadded_type (Etype (gnat_parent)),
+ constant, aliased);
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;
}
|| (TREE_CODE (gnu_result) == PARM_DECL
&& DECL_BY_COMPONENT_PTR_P (gnu_result))))
{
- bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
+ const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
tree renamed_obj;
if (TREE_CODE (gnu_result) == PARM_DECL
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)) != 0
- && (! DECL_RENAMING_GLOBAL_P (gnu_result)
+ && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result))
+ && (!DECL_RENAMING_GLOBAL_P (gnu_result)
|| global_bindings_p ()))
gnu_result = renamed_obj;
else
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
- TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
+ if (read_only)
+ TREE_READONLY (gnu_result) = 1;
}
/* The GNAT tree has the type of a function as the type of its result. Also
|| Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
{
gnu_result_type = TREE_TYPE (gnu_result);
- if (TREE_CODE (gnu_result_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_result_type))
+ if (TYPE_IS_PADDING_P (gnu_result_type))
gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
}
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)
/* If this is an unconstrained array, we know the object has been
allocated with the template in front of the object. So compute
the template address. */
- if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
+ if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr
= convert (build_pointer_type
(TYPE_OBJECT_RECORD_TYPE
}
/* If we're looking for the size of a field, return the field size.
- Otherwise, if the prefix is an object, or if 'Object_Size or
- 'Max_Size_In_Storage_Elements has been specified, the result is the
- GCC size of the type. Otherwise, the result is the RM size of the
- type. */
+ Otherwise, if the prefix is an object, or if we're looking for
+ 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
+ GCC size of the type. Otherwise, it is the RM size of the type. */
if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
else if (TREE_CODE (gnu_prefix) != TYPE_DECL
|| attribute == Attr_Object_Size
|| attribute == Attr_Max_Size_In_Storage_Elements)
{
- /* If this is a padded type, the GCC size isn't relevant to the
- programmer. Normally, what we want is the RM size, which was set
- from the specified size, but if it was not set, we want the size
- of the relevant field. Using the MAX of those two produces the
- right result in all case. Don't use the size of the field if it's
- a self-referential type, since that's never what's wanted. */
- if (TREE_CODE (gnu_type) == RECORD_TYPE
+ /* If the prefix is an object of a padded type, the GCC size isn't
+ relevant to the programmer. Normally what we want is the RM size,
+ which was set from the specified size, but if it was not set, we
+ want the size of the field. Using the MAX of those two produces
+ the right result in all cases. Don't use the size of the field
+ if it's self-referential, since that's never what's wanted. */
+ if (TREE_CODE (gnu_prefix) != TYPE_DECL
&& TYPE_IS_PADDING_P (gnu_type)
&& TREE_CODE (gnu_expr) == COMPONENT_REF)
{
gnu_result = rm_size (gnu_type);
- if (!(CONTAINS_PLACEHOLDER_P
- (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
+ if (!CONTAINS_PLACEHOLDER_P
+ (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
gnu_result
= size_binop (MAX_EXPR, gnu_result,
DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
tree gnu_ptr_type
= TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
- if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
+ if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
&& Present (gnat_actual_subtype))
{
tree gnu_actual_obj_type
unsigned int align;
if (TREE_CODE (gnu_prefix) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
+ && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
gnu_type = TREE_TYPE (gnu_prefix);
else
pa->length = gnu_result;
}
+
+ /* Set the source location onto the predicate of the condition in the
+ 'Length case but do not do it if the expression is cached to avoid
+ messing up the debug info. */
+ else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
+ && TREE_CODE (gnu_result) == COND_EXPR
+ && EXPR_P (TREE_OPERAND (gnu_result, 0)))
+ set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
+ gnat_node);
+
break;
}
case Attr_Component_Size:
if (TREE_CODE (gnu_prefix) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
+ && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
gnu_prefix = maybe_implicit_deref (gnu_prefix);
? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
/* The FUNCTION_DECL node corresponding to the subprogram spec. */
tree gnu_subprog_decl;
+ /* Its RESULT_DECL node. */
+ tree gnu_result_decl;
/* The FUNCTION_TYPE node corresponding to the subprogram spec. */
tree gnu_subprog_type;
tree gnu_cico_list;
= gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
Acts_As_Spec (gnat_node)
&& !present_gnu_tree (gnat_subprog_id));
-
+ gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
+ /* If the function returns by invisible reference, make it explicit in the
+ function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
+ if (TREE_ADDRESSABLE (gnu_subprog_type))
+ {
+ TREE_TYPE (gnu_result_decl)
+ = build_reference_type (TREE_TYPE (gnu_result_decl));
+ relayout_decl (gnu_result_decl);
+ }
+
/* Propagate the debug mode. */
if (!Needs_Debug_Info (gnat_subprog_id))
DECL_IGNORED_P (gnu_subprog_decl) = 1;
gnu_result = end_stmt_group ();
}
- /* If we made a special return label, we need to make a block that contains
- the definition of that label and the copying to the return value. That
- block first contains the function, then the label and copy statement. */
+ /* If we are dealing with a return from an Ada procedure with parameters
+ passed by copy-in/copy-out, we need to return a record containing the
+ final values of these parameters. If the list contains only one entry,
+ return just that entry though.
+
+ For a full description of the copy-in/copy-out parameter mechanism, see
+ the part of the gnat_to_gnu_entity routine dealing with the translation
+ of subprograms.
+
+ We need to make a block that contains the definition of that label and
+ the copying of the return value. It first contains the function, then
+ the label and copy statement. */
if (TREE_VALUE (gnu_return_label_stack))
{
tree gnu_retval;
gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
gnu_cico_list);
- if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
- gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
-
- add_stmt_with_node
- (build_return_expr (DECL_RESULT (gnu_subprog_decl), gnu_retval),
- End_Label (Handled_Statement_Sequence (gnat_node)));
+ add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
+ End_Label (Handled_Statement_Sequence (gnat_node)));
gnat_poplevel ();
gnu_result = end_stmt_group ();
}
static tree
call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
{
- tree gnu_result;
/* The GCC node corresponding to the GNAT subprogram name. This can either
be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
or an indirect reference expression (an INDIRECT_REF node) pointing to a
subprogram. */
- tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
+ tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
/* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
- tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
- tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_subprog_node);
+ tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
+ tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
Entity_Id gnat_formal;
Node_Id gnat_actual;
tree gnu_actual_list = NULL_TREE;
tree gnu_name_list = NULL_TREE;
tree gnu_before_list = NULL_TREE;
tree gnu_after_list = NULL_TREE;
- tree gnu_subprog_call;
+ tree gnu_call;
gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
- /* If we are calling a stubbed function, make this into a raise of
- Program_Error. Elaborate all our args first. */
- if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
- && DECL_STUBBED_P (gnu_subprog_node))
+ /* If we are calling a stubbed function, raise Program_Error, but Elaborate
+ all our args first. */
+ if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
{
+ tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
+ gnat_node, N_Raise_Program_Error);
+
for (gnat_actual = First_Actual (gnat_node);
Present (gnat_actual);
gnat_actual = Next_Actual (gnat_actual))
add_stmt (gnat_to_gnu (gnat_actual));
- {
- tree call_expr
- = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node,
- N_Raise_Program_Error);
-
- if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
- {
- *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
- return build1 (NULL_EXPR, *gnu_result_type_p, call_expr);
- }
- else
- return call_expr;
- }
- }
-
- /* 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 (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
- {
- tree gnu_real_ret_type
- = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
-
- if (!gnu_target)
+ if (Nkind (gnat_node) == N_Function_Call && !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);
-
- /* ??? 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
- the 3.x back-end would generate in the same situation, but we
- don't have a mechanism in Gigi for creating automatic variables
- in the elaboration routines. */
- gnu_target
- = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
- NULL, false, false, false, false, NULL,
- gnat_node);
+ *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
+ return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr);
}
- gnu_actual_list
- = tree_cons (NULL_TREE,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- unchecked_convert (gnu_real_ret_type,
- gnu_target,
- false)),
- NULL_TREE);
-
+ return call_expr;
}
/* The only way we can be making a call via an access type is if Name is an
explicit dereference. In that case, get the list of formal args from the
- type the access type is pointing to. Otherwise, get the formals from
+ type the access type is pointing to. Otherwise, get the formals from the
entity being called. */
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
/* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
- gnat_formal = 0;
+ gnat_formal = Empty;
else
gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
- /* Create the list of the actual parameters as GCC expects it, namely a chain
- of TREE_LIST nodes in which the TREE_VALUE field of each node is a
- parameter-expression and the TREE_PURPOSE field is null. Skip Out
- parameters not passed by reference and don't need to be copied in. */
+ /* Create the list of the actual parameters as GCC expects it, namely a
+ chain of TREE_LIST nodes in which the TREE_VALUE field of each node
+ is an expression and the TREE_PURPOSE field is null. But skip Out
+ parameters not passed by reference and that need not be copied in. */
for (gnat_actual = First_Actual (gnat_node);
Present (gnat_actual);
gnat_formal = Next_Formal_With_Extras (gnat_formal),
gnat_actual = Next_Actual (gnat_actual))
{
- tree gnu_formal
- = (present_gnu_tree (gnat_formal)
- ? get_gnu_tree (gnat_formal) : NULL_TREE);
+ 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));
/* We must suppress conversions that can cause the creation of a
temporary in the Out or In Out case because we need the real
&& Ekind (gnat_formal) != E_In_Parameter)
|| (Nkind (gnat_actual) == N_Type_Conversion
&& Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
- Node_Id gnat_name = (suppress_type_conversion
- ? Expression (gnat_actual) : gnat_actual);
+ Node_Id gnat_name = suppress_type_conversion
+ ? Expression (gnat_actual) : gnat_actual;
tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
tree gnu_actual;
/* If it's possible we may need to use this expression twice, make sure
- that any side-effects are handled via SAVE_EXPRs. Likewise if we need
+ that any side-effects are handled via SAVE_EXPRs; likewise if we need
to force side-effects before the call.
??? This is more conservative than we need since we don't need to do
this for pass-by-ref with no conversion. */
post_error
("misaligned actual cannot be passed by reference", gnat_actual);
- /* For users of Starlet we issue a warning because the
- interface apparently assumes that by-ref parameters
- outlive the procedure invocation. The code still
- will not work as intended, but we cannot do much
- better since other low-level parts of the back-end
- would allocate temporaries at will because of the
- misalignment if we did not do so here. */
+ /* For users of Starlet we issue a warning because the interface
+ apparently assumes that by-ref parameters outlive the procedure
+ invocation. The code still will not work as intended, but we
+ cannot do much better since low-level parts of the back-end
+ would allocate temporaries at will because of the misalignment
+ if we did not do so here. */
else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
{
post_error
/* Otherwise remove unpadding from the object and reset the copy. */
else if (TREE_CODE (gnu_name) == COMPONENT_REF
- && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
+ && TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
/* Otherwise convert to the nominal type of the object if it's
gnu_name = convert (gnu_name_type, gnu_name);
/* Make a SAVE_EXPR to both properly account for potential side
- effects and handle the creation of a temporary copy. Special
- code in gnat_gimplify_expr ensures that the same temporary is
- used as the object and copied back after the call if needed. */
+ effects and handle the creation of a temporary. Special code
+ in gnat_gimplify_expr ensures that the same temporary is used
+ as the object and copied back after the call if needed. */
gnu_name = build1 (SAVE_EXPR, TREE_TYPE (gnu_name), gnu_name);
TREE_SIDE_EFFECTS (gnu_name) = 1;
- /* Set up to move the copy back to the original. */
+ /* Set up to move the copy back to the original if needed. */
if (Ekind (gnat_formal) != E_In_Parameter)
{
tree stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy,
/* If this was a procedure call, we may not have removed any padding.
So do it here for the part we will use as an input, if any. */
if (Ekind (gnat_formal) != E_Out_Parameter
- && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
gnu_actual);
/* We may have suppressed a conversion to the Etype of the actual
since the parent is a procedure call. So put it back here.
??? We use the reverse order compared to the case above because
- of an awkward interaction with the check and actually don't put
- back the conversion at all if a check is emitted. This is also
- done for the conversion to the formal's type just below. */
+ of an awkward interaction with the check. */
if (TREE_CODE (gnu_actual) != SAVE_EXPR)
gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
gnu_actual);
gnu_name);
/* If we have not saved a GCC object for the formal, it means it is an
- Out parameter not passed by reference and that does not need to be
- copied in. Otherwise, look at the PARM_DECL to see if it is passed by
- reference. */
+ Out parameter not passed by reference and that need not be copied in.
+ Otherwise, first see if the PARM_DECL is passed by reference. */
if (gnu_formal
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_REF_P (gnu_formal))
gnu_actual = gnu_name;
/* If we have a padded type, be sure we've removed padding. */
- if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
+ if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
&& TREE_CODE (gnu_actual) != SAVE_EXPR)
gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
gnu_actual);
gnu_actual = maybe_implicit_deref (gnu_actual);
gnu_actual = maybe_unconstrained_array (gnu_actual);
- if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_formal_type))
+ if (TYPE_IS_PADDING_P (gnu_formal_type))
{
gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
gnu_actual = convert (gnu_formal_type, gnu_actual);
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_DESCRIPTOR_P (gnu_formal))
{
- /* If arg is 'Null_Parameter, pass zero descriptor. */
+ /* If this is 'Null_Parameter, pass a zero descriptor. */
if ((TREE_CODE (gnu_actual) == INDIRECT_REF
|| TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
&& TREE_PRIVATE (gnu_actual))
- gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
- integer_zero_node);
+ gnu_actual
+ = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
else
gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
fill_vms_descriptor (gnu_actual,
}
else
{
- tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
+ tree gnu_size;
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 (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
continue;
/* If this is 'Null_Parameter, pass a zero even though we are
dereferencing it. */
- else if (TREE_CODE (gnu_actual) == INDIRECT_REF
- && TREE_PRIVATE (gnu_actual)
- && host_integerp (gnu_actual_size, 1)
- && 0 >= compare_tree_int (gnu_actual_size,
- BITS_PER_WORD))
+ if (TREE_CODE (gnu_actual) == INDIRECT_REF
+ && TREE_PRIVATE (gnu_actual)
+ && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
+ && TREE_CODE (gnu_size) == INTEGER_CST
+ && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
gnu_actual
= unchecked_convert (DECL_ARG_TYPE (gnu_formal),
convert (gnat_type_for_size
- (tree_low_cst (gnu_actual_size, 1),
- 1),
+ (TREE_INT_CST_LOW (gnu_size), 1),
integer_zero_node),
false);
else
gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
}
- gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type),
- gnu_subprog_addr,
- nreverse (gnu_actual_list));
- set_expr_location_from_node (gnu_subprog_call, gnat_node);
+ gnu_call = build_call_list (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr,
+ nreverse (gnu_actual_list));
+ set_expr_location_from_node (gnu_call, gnat_node);
- /* If we return by passing a target, the result is the target after the
- call. We must not emit the call directly here because this might be
- evaluated as part of an expression with conditions to control whether
- the call should be emitted or not. */
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+ /* If it's a function call, the result is the call expression unless a target
+ is specified, in which case we copy the result into the target and return
+ the assignment statement. */
+ if (Nkind (gnat_node) == N_Function_Call)
{
- /* Conceptually, what we need is a COMPOUND_EXPR with the call followed
- by the target object converted to the proper type. Doing so would
- potentially be very inefficient, however, as this expression might
- end up wrapped into an outer SAVE_EXPR later on, which would incur a
- pointless temporary copy of the whole object.
-
- What we do instead is build a COMPOUND_EXPR returning the address of
- the target, and then dereference. Wrapping the COMPOUND_EXPR into a
- SAVE_EXPR later on then only incurs a pointer copy. */
-
- tree gnu_result_type
- = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
-
- /* Build and return
- (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target] */
-
- tree gnu_target_address
- = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_target);
- set_expr_location_from_node (gnu_target_address, gnat_node);
-
- gnu_result
- = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_target_address),
- gnu_subprog_call, gnu_target_address);
-
- gnu_result
- = unchecked_convert (gnu_result_type,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- gnu_result),
- false);
+ tree gnu_result = gnu_call;
+ enum tree_code op_code;
- *gnu_result_type_p = gnu_result_type;
- return gnu_result;
- }
-
- /* If it is a function call, the result is the call expression unless
- a target is specified, in which case we copy the result into the target
- and return the assignment statement. */
- else if (Nkind (gnat_node) == N_Function_Call)
- {
- gnu_result = gnu_subprog_call;
-
- /* If the function returns an unconstrained array or by reference,
- we have to de-dereference the pointer. */
- if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
- || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
+ /* If the function returns an unconstrained array or by direct reference,
+ we have to dereference the pointer. */
+ if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
+ || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
if (gnu_target)
- gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_target, gnu_result);
+ {
+ /* ??? If the return type has non-constant size, then force the
+ return slot optimization as we would not be able to generate
+ a temporary. That's what has been done historically. */
+ if (TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_subprog_type))))
+ op_code = MODIFY_EXPR;
+ else
+ op_code = INIT_EXPR;
+
+ gnu_result
+ = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result);
+ }
else
*gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
return gnu_result;
}
- /* If this is the case where the GNAT tree contains a procedure call
- but the Ada procedure has copy in copy out parameters, the special
- parameter passing mechanism must be used. */
- else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
+ /* If this is the case where the GNAT tree contains a procedure call but the
+ Ada procedure has copy-in/copy-out parameters, then the special parameter
+ passing mechanism must be used. */
+ if (TYPE_CI_CO_LIST (gnu_subprog_type))
{
/* List of FIELD_DECLs associated with the PARM_DECLs of the copy
in copy out parameters. */
{
tree gnu_name;
- gnu_subprog_call = save_expr (gnu_subprog_call);
+ /* The call sequence must contain one and only one call, even though
+ the function is const or pure. So force a SAVE_EXPR. */
+ gnu_call = build1 (SAVE_EXPR, TREE_TYPE (gnu_call), gnu_call);
+ TREE_SIDE_EFFECTS (gnu_call) = 1;
gnu_name_list = nreverse (gnu_name_list);
/* If any of the names had side-effects, ensure they are all
evaluated before the call. */
- for (gnu_name = gnu_name_list; gnu_name;
+ for (gnu_name = gnu_name_list;
+ gnu_name;
gnu_name = TREE_CHAIN (gnu_name))
if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
append_to_statement_list (TREE_VALUE (gnu_name),
either the result of the function if there is only a single such
parameter or the appropriate field from the record returned. */
tree gnu_result
- = length == 1 ? gnu_subprog_call
- : build_component_ref (gnu_subprog_call, NULL_TREE,
+ = length == 1
+ ? gnu_call
+ : build_component_ref (gnu_call, NULL_TREE,
TREE_PURPOSE (scalar_return_list),
false);
= maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
/* If the result is a padded type, remove the padding. */
- if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
- gnu_result = convert (TREE_TYPE (TYPE_FIELDS
- (TREE_TYPE (gnu_result))),
- gnu_result);
+ if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
+ gnu_result
+ = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
+ gnu_result);
/* If the actual is a type conversion, the real target object is
denoted by the inner Expression and we need to convert the
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);
scalar_return_list = TREE_CHAIN (scalar_return_list);
gnu_name_list = TREE_CHAIN (gnu_name_list);
}
- }
+ }
else
- append_to_statement_list (gnu_subprog_call, &gnu_before_list);
+ append_to_statement_list (gnu_call, &gnu_before_list);
append_to_statement_list (gnu_after_list, &gnu_before_list);
+
return gnu_before_list;
}
\f
invalidate_global_renaming_pointers ();
}
\f
-/* Return whether GNAT_NODE, an unchecked type conversion, is on the LHS
- of an assignment and a no-op as far as gigi is concerned. */
+/* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
+ as gigi is concerned. This is used to avoid conversions on the LHS. */
static bool
-unchecked_conversion_lhs_nop (Node_Id gnat_node)
+unchecked_conversion_nop (Node_Id gnat_node)
{
Entity_Id from_type, to_type;
- /* The conversion must be on the LHS of an assignment. Otherwise, even
- if the conversion was essentially a no-op, it could de facto ensure
- type consistency and this should be preserved. */
+ /* The conversion must be on the LHS of an assignment or an actual parameter
+ of a call. Otherwise, even if the conversion was essentially a no-op, it
+ could de facto ensure type consistency and this should be preserved. */
if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement
- && Name (Parent (gnat_node)) == gnat_node))
+ && Name (Parent (gnat_node)) == gnat_node)
+ && !(Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
+ && Name (Parent (gnat_node)) != gnat_node))
return false;
from_type = Etype (Expression (gnat_node));
gnu_array_object = maybe_unconstrained_array (gnu_array_object);
/* If we got a padded type, remove it too. */
- if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
+ if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
gnu_array_object
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
gnu_array_object);
gnu_result = gnat_to_gnu (Expression (gnat_node));
/* Skip further processing if the conversion is deemed a no-op. */
- if (unchecked_conversion_lhs_nop (gnat_node))
+ if (unchecked_conversion_nop (gnat_node))
{
gnu_result_type = TREE_TYPE (gnu_result);
break;
case N_In:
case N_Not_In:
{
- tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
+ tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
Node_Id gnat_range = Right_Opnd (gnat_node);
- tree gnu_low;
- tree gnu_high;
+ tree gnu_low, gnu_high;
- /* GNAT_RANGE is either an N_Range node or an identifier
- denoting a subtype. */
+ /* GNAT_RANGE is either an N_Range node or an identifier denoting a
+ subtype. */
if (Nkind (gnat_range) == N_Range)
{
gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- /* If LOW and HIGH are identical, perform an equality test.
- Otherwise, ensure that GNU_OBJECT is only evaluated once
- and perform a full range test. */
+ /* If LOW and HIGH are identical, perform an equality test. Otherwise,
+ ensure that GNU_OBJ is evaluated only once and perform a full range
+ test. */
if (operand_equal_p (gnu_low, gnu_high, 0))
- gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
- gnu_object, gnu_low);
+ gnu_result
+ = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
else
{
- gnu_object = protect_multiple_eval (gnu_object);
+ tree t1, t2;
+ gnu_obj = protect_multiple_eval (gnu_obj);
+ t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
+ if (EXPR_P (t1))
+ set_expr_location_from_node (t1, gnat_node);
+ t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
+ if (EXPR_P (t2))
+ set_expr_location_from_node (t2, gnat_node);
gnu_result
- = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
- build_binary_op (GE_EXPR, gnu_result_type,
- gnu_object, gnu_low),
- build_binary_op (LE_EXPR, gnu_result_type,
- gnu_object, gnu_high));
+ = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
}
if (kind == N_Not_In)
case N_Return_Statement:
{
- /* The gnu function type of the subprogram currently processed. */
- tree gnu_subprog_type = TREE_TYPE (current_function_decl);
- /* The return value from the subprogram. */
- tree gnu_ret_val = NULL_TREE;
- /* The place to put the return value. */
- tree gnu_lhs;
-
- /* If we are dealing with a "return;" from an Ada procedure with
- parameters passed by copy in copy out, we need to return a record
- containing the final values of these parameters. If the list
- contains only one entry, return just that entry.
-
- For a full description of the copy in copy out parameter mechanism,
- see the part of the gnat_to_gnu_entity routine dealing with the
- translation of subprograms.
-
- But if we have a return label defined, convert this into
- a branch to that label. */
+ tree gnu_ret_val, gnu_ret_obj;
+ /* If we have a return label defined, convert this into a branch to
+ that label. The return proper will be handled elsewhere. */
if (TREE_VALUE (gnu_return_label_stack))
{
gnu_result = build1 (GOTO_EXPR, void_type_node,
break;
}
- else if (TYPE_CI_CO_LIST (gnu_subprog_type))
+ /* If the subprogram is a function, we must return the expression. */
+ if (Present (Expression (gnat_node)))
{
- gnu_lhs = DECL_RESULT (current_function_decl);
- if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
- gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
- else
- gnu_ret_val
- = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
- TYPE_CI_CO_LIST (gnu_subprog_type));
- }
-
- /* If the Ada subprogram is a function, we just need to return the
- expression. If the subprogram returns an unconstrained
- array, we have to allocate a new version of the result and
- return it. If we return by reference, return a pointer. */
-
- else if (Present (Expression (gnat_node)))
- {
- /* If the current function returns by target pointer and we
- are doing a call, pass that target to the call. */
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
- && Nkind (Expression (gnat_node)) == N_Function_Call)
+ tree gnu_subprog_type = TREE_TYPE (current_function_decl);
+ tree gnu_result_decl = DECL_RESULT (current_function_decl);
+ 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. */
+ if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
+ && TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
+ && CONTAINS_PLACEHOLDER_P
+ (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
+ to the return value. */
+ if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
+ || By_Ref (gnat_node))
+ gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
+
+ /* Otherwise, if it returns an unconstrained array, we have to
+ allocate a new version of the result and return it. */
+ else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
{
- gnu_lhs
- = build_unary_op (INDIRECT_REF, NULL_TREE,
- DECL_ARGUMENTS (current_function_decl));
- gnu_result = call_to_gnu (Expression (gnat_node),
- &gnu_result_type, gnu_lhs);
+ gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
+ gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
+ gnu_ret_val,
+ TREE_TYPE (gnu_subprog_type),
+ Procedure_To_Call (gnat_node),
+ Storage_Pool (gnat_node),
+ gnat_node, false);
}
- else
+
+ /* If the subprogram 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_val = gnat_to_gnu (Expression (gnat_node));
-
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
- /* The original return type was unconstrained so dereference
- the TARGET pointer in the actual return value's type. */
- gnu_lhs
- = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
- DECL_ARGUMENTS (current_function_decl));
- else
- gnu_lhs = DECL_RESULT (current_function_decl);
-
- /* Do not remove the padding from GNU_RET_VAL if the inner
- type is self-referential since we want to allocate the fixed
- size in that case. */
- if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
- gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
-
- if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
- || By_Ref (gnat_node))
- gnu_ret_val
- = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
-
- else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
- {
- gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
- gnu_ret_val
- = build_allocator (TREE_TYPE (gnu_ret_val),
- gnu_ret_val,
- TREE_TYPE (gnu_subprog_type),
- Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node),
- gnat_node, false);
- }
+ gnu_ret_obj
+ = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
+ gnu_result_decl);
+ gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
+ gnu_ret_obj, 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
- /* If the Ada subprogram is a regular procedure, just return. */
- gnu_lhs = NULL_TREE;
-
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
{
- if (gnu_ret_val)
- gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_lhs, gnu_ret_val);
- add_stmt_with_node (gnu_result, gnat_node);
- gnu_lhs = NULL_TREE;
+ gnu_ret_val = NULL_TREE;
+ gnu_ret_obj = NULL_TREE;
}
- gnu_result = build_return_expr (gnu_lhs, gnu_ret_val);
+ gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
}
break;
a fat pointer, then go back below to a thin pointer. The
reason for this is that we need a fat pointer someplace in
order to properly compute the size. */
- if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
+ if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_unary_op (INDIRECT_REF, NULL_TREE,
gnu_ptr));
have been allocated with the template in front of the object.
So pass the template address, but get the total size. Do this
by converting to a thin pointer. */
- if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
+ if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr
= convert (build_pointer_type
(TYPE_OBJECT_RECORD_TYPE
gnu_actual_obj_type
= gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
- if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
+ if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
gnu_actual_obj_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
/* But if the result is a fat pointer type, we have no mechanism to
do that, so we unconditionally warn in problematic cases. */
- else if (TYPE_FAT_POINTER_P (gnu_target_type))
+ else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
{
tree gnu_source_array_type
- = TYPE_FAT_POINTER_P (gnu_source_type)
+ = TYPE_IS_FAT_POINTER_P (gnu_source_type)
? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
: NULL_TREE;
tree gnu_target_array_type
if ((TYPE_DUMMY_P (gnu_target_array_type)
|| get_alias_set (gnu_target_array_type) != 0)
- && (!TYPE_FAT_POINTER_P (gnu_source_type)
+ && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
|| (TYPE_DUMMY_P (gnu_source_array_type)
!= TYPE_DUMMY_P (gnu_target_array_type))
|| (TYPE_DUMMY_P (gnu_source_array_type)
case N_SCIL_Dispatch_Table_Object_Init:
case N_SCIL_Dispatch_Table_Tag_Init:
case N_SCIL_Dispatching_Call:
+ case N_SCIL_Membership_Test:
case N_SCIL_Tag_Init:
/* SCIL nodes require no processing for GCC. */
gnu_result = alloc_stmt_list ();
&& ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
&& Name (Parent (gnat_node)) == gnat_node)
|| (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
- && unchecked_conversion_lhs_nop (Parent (gnat_node)))
+ && unchecked_conversion_nop (Parent (gnat_node)))
|| (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
&& Name (Parent (gnat_node)) != gnat_node)
|| Nkind (Parent (gnat_node)) == N_Parameter_Association
size: in that case it must be an object of unconstrained type
with a default discriminant and we want to avoid copying too
much data. */
- if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
+ if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
(TREE_TYPE (gnu_result))))))
gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
&& TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
{
/* Remove any padding. */
- if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
+ if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
gnu_result);
}
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);
-
if (TREE_CODE (gnu_decl) == VAR_DECL
|| TREE_CODE (gnu_decl) == CONST_DECL)
{
MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
MARK_VISITED (DECL_INITIAL (gnu_decl));
}
+ /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
+ else if (TREE_CODE (gnu_decl) == TYPE_DECL
+ && ((TREE_CODE (type) == RECORD_TYPE
+ && !TYPE_FAT_POINTER_P (type))
+ || TREE_CODE (type) == UNION_TYPE
+ || TREE_CODE (type) == QUAL_UNION_TYPE))
+ MARK_VISITED (TYPE_ADA_SIZE (type));
}
else
add_stmt_with_node (gnu_stmt, gnat_entity);
{
/* If GNU_DECL has a padded type, convert it to the unpadded
type so the assignment is done properly. */
- if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
+ if (TYPE_IS_PADDING_P (type))
t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
else
t = gnu_decl;
- gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, t, gnu_init);
+ gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
DECL_INITIAL (gnu_decl) = NULL_TREE;
if (TREE_READONLY (gnu_decl))
if (Present (Address_Clause (gnat_entity)))
gnu_old = 0;
- /* Don't do anything for class-wide types they are always
- transformed into their root type. */
- if (Ekind (gnat_entity) == E_Class_Wide_Type
- || (Ekind (gnat_entity) == E_Class_Wide_Subtype
- && Present (Equivalent_Type (gnat_entity))))
+ /* Don't do anything for class-wide types as they are always transformed
+ into their root type. */
+ if (Ekind (gnat_entity) == E_Class_Wide_Type)
return;
/* Don't do anything for subprograms that may have been elaborated before
&& !truncatep)
{
REAL_VALUE_TYPE half_minus_pred_half, pred_half;
- tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type;
+ tree gnu_conv, gnu_zero, gnu_comp, calc_type;
tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
const struct real_format *fmt;
= FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
/* FIXME: Should not have padding in the first place. */
- if (TREE_CODE (calc_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (calc_type))
+ if (TYPE_IS_PADDING_P (calc_type))
calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
/* Compute the exact value calc_type'Pred (0.5) at compile time. */
gnu_pred_half = build_real (calc_type, pred_half);
/* If the input is strictly negative, subtract this value
- and otherwise add it from the input. For 0.5, the result
+ and otherwise add it from the input. For 0.5, the result
is exactly between 1.0 and the machine number preceding 1.0
- (for calc_type). Since the last bit of 1.0 is even, this 0.5
+ (for calc_type). Since the last bit of 1.0 is even, this 0.5
will round to 1.0, while all other number with an absolute
- value less than 0.5 round to 0.0. For larger numbers exactly
+ value less than 0.5 round to 0.0. For larger numbers exactly
halfway between integers, rounding will always be correct as
the true mathematical result will be closer to the higher
- integer compared to the lower one. So, this constant works
+ integer compared to the lower one. So, this constant works
for all floating-point numbers.
The reason to use the same constant with subtract/add instead
conversion of the input to the calc_type (if necessary). */
gnu_zero = convert (gnu_in_basetype, integer_zero_node);
- gnu_saved_result = save_expr (gnu_result);
- gnu_conv = convert (calc_type, gnu_saved_result);
- gnu_comp = build2 (GE_EXPR, integer_type_node,
- gnu_saved_result, gnu_zero);
+ gnu_result = protect_multiple_eval (gnu_result);
+ gnu_conv = convert (calc_type, gnu_result);
+ gnu_comp
+ = fold_build2 (GE_EXPR, integer_type_node, gnu_result, gnu_zero);
gnu_add_pred_half
- = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
+ = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
gnu_subtract_pred_half
- = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
- gnu_result = build3 (COND_EXPR, calc_type, gnu_comp,
- gnu_add_pred_half, gnu_subtract_pred_half);
+ = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
+ gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
+ gnu_add_pred_half, gnu_subtract_pred_half);
}
if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
else
gnu_result = convert (gnu_base_type, gnu_result);
- /* Finally, do the range check if requested. Note that if the
- result type is a modular type, the range check is actually
- an overflow check. */
-
+ /* Finally, do the range check if requested. Note that if the result type
+ is a modular type, the range check is actually an overflow check. */
if (rangep
|| (TREE_CODE (gnu_base_type) == INTEGER_TYPE
&& TYPE_MODULAR_P (gnu_base_type) && overflowp))
case CALL_EXPR:
case PLUS_EXPR:
case MINUS_EXPR:
+ case BIT_IOR_EXPR:
+ case BIT_XOR_EXPR:
+ case BIT_AND_EXPR:
+ case BIT_NOT_EXPR:
/* All rvalues are deemed addressable since taking their address will
force a temporary to be created by the middle-end. */
return true;
|| DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
>= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
/* The field of a padding record is always addressable. */
- || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
+ || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
&& addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
case ARRAY_REF: case ARRAY_RANGE_REF:
maybe_implicit_deref (tree exp)
{
/* If the type is a pointer, dereference it. */
-
- if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
+ if (POINTER_TYPE_P (TREE_TYPE (exp))
+ || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
/* If we got a padded type, remove it too. */
- if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
+ if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
return exp;
protect_multiple_eval (tree exp)
{
tree type = TREE_TYPE (exp);
+ enum tree_code code = TREE_CODE (exp);
/* If EXP has no side effects, we theoritically don't need to do anything.
However, we may be recursively passed more and more complex expressions
Similarly, if we're indirectly referencing something, we only
need to protect the address since the data itself can't change
in these situations. */
- if (TREE_CODE (exp) == NON_LVALUE_EXPR
- || CONVERT_EXPR_P (exp)
- || TREE_CODE (exp) == VIEW_CONVERT_EXPR
- || TREE_CODE (exp) == INDIRECT_REF
- || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
- return build1 (TREE_CODE (exp), type,
- protect_multiple_eval (TREE_OPERAND (exp, 0)));
-
- /* If this is a fat pointer or something that can be placed into a
- register, just make a SAVE_EXPR. */
- if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
+ if (code == NON_LVALUE_EXPR
+ || CONVERT_EXPR_CODE_P (code)
+ || code == VIEW_CONVERT_EXPR
+ || code == INDIRECT_REF
+ || code == UNCONSTRAINED_ARRAY_REF)
+ return build1 (code, type, protect_multiple_eval (TREE_OPERAND (exp, 0)));
+
+ /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
+ This may be more efficient, but will also allow us to more easily find
+ the match for the PLACEHOLDER_EXPR. */
+ if (code == COMPONENT_REF
+ && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
+ return build3 (code, type, protect_multiple_eval (TREE_OPERAND (exp, 0)),
+ TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
+
+ /* If this is a fat pointer or something that can be placed in a register,
+ just make a SAVE_EXPR. Likewise for a CALL_EXPR as large objects are
+ returned via invisible reference in most ABIs so the temporary will
+ directly be filled by the callee. */
+ if (TYPE_IS_FAT_POINTER_P (type)
+ || TYPE_MODE (type) != BLKmode
+ || code == CALL_EXPR)
return save_expr (exp);
- /* Otherwise, reference, protect the address and dereference. */
+ /* Otherwise reference, protect the address and dereference. */
return
build_unary_op (INDIRECT_REF, type,
save_expr (build_unary_op (ADDR_EXPR,
NULL_TREE, NULL_TREE);
break;
- case COMPOUND_EXPR:
- result = gnat_stabilize_reference_1 (ref, force);
- break;
-
case CALL_EXPR:
- /* This generates better code than the scheme in protect_multiple_eval
- because large objects will be returned via invisible reference in
- most ABIs so the temporary will directly be filled by the callee. */
+ case COMPOUND_EXPR:
result = gnat_stabilize_reference_1 (ref, force);
break;
return ref;
}
- TREE_READONLY (result) = TREE_READONLY (ref);
-
- /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
- expression may not be sustained across some paths, such as the way via
- build1 for INDIRECT_REF. We re-populate those flags here for the general
- case, which is consistent with the GCC version of this routine.
+ /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression
+ may not be sustained across some paths, such as the way via build1 for
+ INDIRECT_REF. We reset those flags here in the general case, which is
+ consistent with the GCC version of this routine.
Special care should be taken regarding TREE_SIDE_EFFECTS, because some
- paths introduce side effects where there was none initially (e.g. calls
- to save_expr), and we also want to keep track of that. */
-
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
+ paths introduce side-effects where there was none initially (e.g. if a
+ SAVE_EXPR is built) and we also want to keep track of that. */
+ TREE_READONLY (result) = TREE_READONLY (ref);
TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
+ TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
return result;
}
-/* Wrapper around maybe_stabilize_reference, for common uses without
- lvalue restrictions and without need to examine the success
- indication. */
+/* Wrapper around maybe_stabilize_reference, for common uses without lvalue
+ restrictions and without the need to examine the success indication. */
static tree
gnat_stabilize_reference (tree ref, bool force)
to a const array but whose index contains side-effects. But we can
ignore things that are actual constant or that already have been
handled by this function. */
-
if (TREE_CONSTANT (e) || code == SAVE_EXPR)
return e;
switch (TREE_CODE_CLASS (code))
{
case tcc_exceptional:
- case tcc_type:
case tcc_declaration:
case tcc_comparison:
- case tcc_statement:
case tcc_expression:
case tcc_reference:
case tcc_vl_exp:
fat pointer. This may be more efficient, but will also allow
us to more easily find the match for the PLACEHOLDER_EXPR. */
if (code == COMPONENT_REF
- && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
- result = build3 (COMPONENT_REF, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
- force),
- TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
+ && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
+ result
+ = build3 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
+ TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
+ /* If the expression has side-effects, then encase it in a SAVE_EXPR
+ so that it will only be evaluated once. */
+ /* The tcc_reference and tcc_comparison classes could be handled as
+ below, but it is generally faster to only evaluate them once. */
else if (TREE_SIDE_EFFECTS (e) || force)
return save_expr (e);
else
return e;
break;
- case tcc_constant:
- /* Constants need no processing. In fact, we should never reach
- here. */
- return e;
-
case tcc_binary:
/* Recursively stabilize each operand. */
- result = build2 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
- force));
+ result
+ = build2 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
break;
case tcc_unary:
/* Recursively stabilize each operand. */
- result = build1 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
- force));
+ result
+ = build1 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force));
break;
default:
gcc_unreachable ();
}
+ /* See similar handling in maybe_stabilize_reference. */
TREE_READONLY (result) = TREE_READONLY (e);
-
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
+ TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
+
return result;
}
\f
OSDN Git Service
