* *
* 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 extract_values (tree, tree);
static tree pos_to_constructor (Node_Id, tree, Entity_Id);
static tree maybe_implicit_deref (tree);
-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, 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, which is
+ an N_Attribute_Reference. */
- 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_for_attribute_p (Node_Id gnat_node)
+{
+ switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
+ {
+ case Attr_Pos:
+ case Attr_Val:
+ case Attr_Pred:
+ case Attr_Succ:
+ case Attr_First:
+ case Attr_Last:
+ case Attr_Range_Length:
+ case Attr_Length:
+ case Attr_Object_Size:
+ case Attr_Value_Size:
+ case Attr_Component_Size:
+ case Attr_Max_Size_In_Storage_Elements:
+ case Attr_Min:
+ case Attr_Max:
+ case Attr_Null_Parameter:
+ case Attr_Passed_By_Reference:
+ case Attr_Mechanism_Code:
+ return 0;
+
+ case Attr_Address:
+ case Attr_Access:
+ case Attr_Unchecked_Access:
+ case Attr_Unrestricted_Access:
+ case Attr_Code_Address:
+ case Attr_Pool_Address:
+ case Attr_Size:
+ case Attr_Alignment:
+ case Attr_Bit_Position:
+ case Attr_Position:
+ case Attr_First_Bit:
+ case Attr_Last_Bit:
+ case Attr_Bit:
+ default:
+ return 1;
+ }
+}
+
+/* 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. If it is, ADDRESS_OF_CONSTANT indicates
+ whether its value is the address of a constant and ALIASED whether it is
+ aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
+
+ 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 address_of_constant, bool aliased)
{
Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
return 1;
case N_Attribute_Reference:
- {
- unsigned char id = Get_Attribute_Id (Attribute_Name (gnat_parent));
- return id == Attr_Address
- || id == Attr_Access
- || id == Attr_Unchecked_Access
- || id == Attr_Unrestricted_Access;
- }
+ return lvalue_required_for_attribute_p (gnat_parent);
case N_Parameter_Association:
case N_Function_Call:
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,
+ address_of_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,
+ address_of_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_Object_Declaration:
/* We cannot use a constructor if this 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 (Defining_Entity (gnat_parent));
+ return ((Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
+ && Is_Atomic (Defining_Entity (gnat_parent)))
+ /* We don't use a constructor if this is a class-wide object
+ because the effective type of the object is the equivalent
+ type of the class-wide subtype and it smashes most of the
+ data into an array of bytes to which we cannot convert. */
+ || Ekind ((Etype (Defining_Entity (gnat_parent))))
+ == E_Class_Wide_Subtype);
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, address_of_constant, aliased);
+
+ case N_Explicit_Dereference:
+ /* We look through dereferences for address of constant because we need
+ to handle the special cases listed above. */
+ if (constant && address_of_constant)
+ return lvalue_required_p (gnat_parent,
+ get_unpadded_type (Etype (gnat_parent)),
+ true, false, true);
+
+ /* ... fall through ... */
default:
return 0;
statement alternative or a record discriminant. There is no possible
volatile-ness short-circuit here since Volatile constants must bei
imported per C.6. */
- if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type)
+ if (Ekind (gnat_temp) == E_Constant
+ && Is_Scalar_Type (gnat_temp_type)
&& !Is_Imported (gnat_temp)
&& Present (Address_Clause (gnat_temp)))
{
- require_lvalue = lvalue_required_p (gnat_node, gnu_result_type,
- Is_Aliased (gnat_temp));
+ require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
+ false, 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));
}
&& DECL_P (gnu_result)
&& DECL_INITIAL (gnu_result))
{
- tree object
- = (TREE_CODE (gnu_result) == CONST_DECL
- ? DECL_CONST_CORRESPONDING_VAR (gnu_result) : gnu_result);
-
- /* If there is a corresponding variable, we only want to return
- 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,
- Is_Aliased (gnat_temp));
-
- if (!object || !require_lvalue)
+ bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
+ && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
+ bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
+ && DECL_CONST_ADDRESS_P (gnu_result));
+
+ /* If there is a (corresponding) variable or this is the address of a
+ constant, we only want to return the initializer if an lvalue isn't
+ required. Evaluate this now if we have not already done so. */
+ if ((!constant_only || address_of_constant) && require_lvalue < 0)
+ require_lvalue
+ = lvalue_required_p (gnat_node, gnu_result_type, true,
+ address_of_constant, Is_Aliased (gnat_temp));
+
+ if ((constant_only && !address_of_constant) || !require_lvalue)
gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
}
if (Do_Range_Check (First (Expressions (gnat_node))))
{
- gnu_expr = protect_multiple_eval (gnu_expr);
+ gnu_expr = gnat_protect_expr (gnu_expr);
gnu_expr
= emit_check
(build_binary_op (EQ_EXPR, integer_type_node,
/* 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
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'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);
Present (gnat_when);
gnat_when = Next_Non_Pragma (gnat_when))
{
+ bool choices_added_p = false;
Node_Id gnat_choice;
- int choices_added = 0;
/* First compile all the different case choices for the current WHEN
alternative. */
gnu_low, gnu_high,
create_artificial_label (input_location)),
gnat_choice);
- choices_added++;
+ choices_added_p = true;
}
}
/* Push a binding level here in case variables are declared as we want
them to be local to this set of statements instead of to the block
containing the Case statement. */
- if (choices_added > 0)
+ if (choices_added_p)
{
add_stmt (build_stmt_group (Statements (gnat_when), true));
add_stmt (build1 (GOTO_EXPR, void_type_node,
? 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
- object in this case, either to pass its address if it's passed
- by reference or as target of the back copy done after the call
- if it uses the copy-in copy-out mechanism. 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. */
+ /* 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
+ address if it's passed by reference or as target of the back copy
+ done after the call if it uses the copy-in copy-out mechanism.
+ 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
= ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
&& 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. */
if (Ekind (gnat_formal) != E_In_Parameter)
- gnu_name = gnat_stabilize_reference (gnu_name, true);
+ gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
/* 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
{
tree gnu_copy = gnu_name;
- /* If the type is by_reference, a copy is not allowed. */
- if (Is_By_Reference_Type (Etype (gnat_formal)))
- 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. */
- else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
- {
- post_error
- ("?possible violation of implicit assumption", gnat_actual);
- post_error_ne
- ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
- Entity (Name (gnat_node)));
- post_error_ne ("?because of misalignment of &", gnat_actual,
- gnat_formal);
- }
-
/* If the actual type of the object is already the nominal type,
we have nothing to do, except if the size is self-referential
in which case we'll remove the unpadding below. */
/* 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_type)))
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
+ /* Make a SAVE_EXPR to force 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. */
+ /* If the type is passed by reference, a copy is not allowed. */
+ if (TREE_ADDRESSABLE (gnu_formal_type))
+ {
+ post_error ("misaligned actual cannot be passed by reference",
+ gnat_actual);
+
+ /* Avoid the back-end assertion on temporary creation. */
+ gnu_name = TREE_OPERAND (gnu_name, 0);
+ }
+
+ /* 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
+ ("?possible violation of implicit assumption", gnat_actual);
+ post_error_ne
+ ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
+ Entity (Name (gnat_node)));
+ post_error_ne ("?because of misalignment of &", gnat_actual,
+ gnat_formal);
+ }
+
+ /* 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);
-
- /* Do any needed conversions for the actual and make sure that it is
- in range of the formal's type. */
- if (suppress_type_conversion)
- {
- /* Put back the conversion we suppressed above in the computation
- of the real object. Note that we treat a conversion between
- aggregate types as if it is an unchecked conversion here. */
- gnu_actual
- = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
- gnu_actual,
- (Nkind (gnat_actual)
- == N_Unchecked_Type_Conversion)
- && No_Truncation (gnat_actual));
-
- if (Ekind (gnat_formal) != E_Out_Parameter
- && Do_Range_Check (gnat_actual))
- gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal),
- gnat_actual);
- }
+ gnu_actual
+ = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
+
+ /* Put back the conversion we suppressed above in the computation of the
+ real object. And even if we didn't suppress any conversion there, we
+ may have suppressed a conversion to the Etype of the actual earlier,
+ since the parent is a procedure call, so put it back here. */
+ if (suppress_type_conversion
+ && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
+ gnu_actual
+ = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
+ gnu_actual, No_Truncation (gnat_actual));
else
- {
- if (Ekind (gnat_formal) != E_Out_Parameter
- && Do_Range_Check (gnat_actual))
- gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal),
- gnat_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. */
- if (TREE_CODE (gnu_actual) != SAVE_EXPR)
- gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
- gnu_actual);
- }
+ gnu_actual
+ = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
+
+ /* Make sure that the actual is in range of the formal's type. */
+ if (Ekind (gnat_formal) != E_Out_Parameter
+ && Do_Range_Check (gnat_actual))
+ gnu_actual
+ = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
+ /* And convert it to this type. */
if (TREE_CODE (gnu_actual) != SAVE_EXPR)
gnu_actual = convert (gnu_formal_type, gnu_actual);
&& TREE_CODE (gnu_name) == CONSTRUCTOR
&& TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
- gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
- gnu_name);
+ gnu_name
+ = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), 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_result = gnu_call;
+ enum tree_code op_code;
- 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);
-
- *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));
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_SCIL_Dispatch_Table_Object_Init
- && Nkind (gnat_node) != N_SCIL_Dispatch_Table_Tag_Init
- && Nkind (gnat_node) != N_SCIL_Dispatching_Call
- && Nkind (gnat_node) != N_SCIL_Tag_Init)
- || 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))))
{
gnu_expr, false, Is_Public (gnat_temp),
false, false, NULL, gnat_temp);
else
- gnu_expr = maybe_variable (gnu_expr);
+ gnu_expr = gnat_save_expr (gnu_expr);
save_gnu_tree (gnat_node, gnu_expr, true);
}
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. */
- 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);
(TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
- gnu_min_expr = protect_multiple_eval (gnu_min_expr);
- gnu_max_expr = protect_multiple_eval (gnu_max_expr);
+ gnu_min_expr = gnat_protect_expr (gnu_min_expr);
+ gnu_max_expr = gnat_protect_expr (gnu_max_expr);
/* Derive a good type to convert everything to. */
gnu_expr_type = get_base_type (gnu_index_type);
? Designated_Type (Etype
(Prefix (gnat_node)))
: Etype (Prefix (gnat_node))))
- gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
+ gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL);
gnu_result
= build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
(Nkind (Parent (gnat_node))
- == N_Attribute_Reference));
+ == N_Attribute_Reference)
+ && lvalue_required_for_attribute_p
+ (Parent (gnat_node)));
}
gcc_assert (gnu_result);
&& 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_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 = gnat_protect_expr (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 (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;
break;
case N_Null_Statement:
- gnu_result = alloc_stmt_list ();
+ /* When not optimizing, turn null statements from source into gotos to
+ the next statement that the middle-end knows how to preserve. */
+ if (!optimize && Comes_From_Source (gnat_node))
+ {
+ tree stmt, label = create_label_decl (NULL_TREE);
+ start_stmt_group ();
+ stmt = build1 (GOTO_EXPR, void_type_node, label);
+ set_expr_location_from_node (stmt, gnat_node);
+ add_stmt (stmt);
+ stmt = build1 (LABEL_EXPR, void_type_node, label);
+ set_expr_location_from_node (stmt, gnat_node);
+ add_stmt (stmt);
+ gnu_result = end_stmt_group ();
+ }
+ else
+ gnu_result = alloc_stmt_list ();
break;
case N_Assignment_Statement:
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))
- {
- 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 subprogram is a function, we must return the expression. */
+ 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,
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
/* 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 ();
if (TREE_SIDE_EFFECTS (gnu_result)
&& (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
|| CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
- gnu_result = gnat_stabilize_reference (gnu_result, false);
+ gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
/* Now convert the result to the result type, unless we are in one of the
following cases:
&& ((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);
}
/* 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 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))
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 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 in static memory when
- the reference is in an elaboration procedure. */
- if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
+ if (TREE_CODE (op) == CONSTRUCTOR)
{
- tree new_var = create_tmp_var (TREE_TYPE (op), "C");
- TREE_ADDRESSABLE (new_var) = 1;
+ /* If we are taking the address of a constant CONSTRUCTOR, make sure
+ it is put into static memory. We know it's going to be read-only
+ given the semantics we have and it must be in static memory when
+ the reference is in an elaboration procedure. */
+ if (TREE_CONSTANT (op))
+ {
+ tree new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
+ TREE_ADDRESSABLE (new_var) = 1;
+ gimple_add_tmp_var (new_var);
- TREE_READONLY (new_var) = 1;
- TREE_STATIC (new_var) = 1;
- DECL_INITIAL (new_var) = op;
+ TREE_READONLY (new_var) = 1;
+ TREE_STATIC (new_var) = 1;
+ DECL_INITIAL (new_var) = op;
+
+ TREE_OPERAND (expr, 0) = new_var;
+ recompute_tree_invariant_for_addr_expr (expr);
+ }
+
+ /* Otherwise explicitly create the local temporary. That's required
+ if the type is passed by reference. */
+ else
+ {
+ tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
+ TREE_ADDRESSABLE (new_var) = 1;
+ 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;
+ recompute_tree_invariant_for_addr_expr (expr);
+ }
- TREE_OPERAND (expr, 0) = new_var;
- recompute_tree_invariant_for_addr_expr (expr);
return GS_ALL_DONE;
}
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
{
gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
- operand = protect_multiple_eval (operand);
+ operand = gnat_protect_expr (operand);
return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
operand, TYPE_MIN_VALUE (gnu_type)),
build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
tree right, Node_Id gnat_node)
{
- tree lhs = protect_multiple_eval (left);
- tree rhs = protect_multiple_eval (right);
+ tree lhs = gnat_protect_expr (left);
+ tree rhs = gnat_protect_expr (right);
tree type_max = TYPE_MAX_VALUE (gnu_type);
tree type_min = TYPE_MIN_VALUE (gnu_type);
tree gnu_expr;
return gnu_expr;
/* Checked expressions must be evaluated only once. */
- gnu_expr = protect_multiple_eval (gnu_expr);
+ gnu_expr = gnat_protect_expr (gnu_expr);
/* There's no good type to use here, so we might as well use
integer_type_node. Note that the form of the check is
tree gnu_expr_check;
/* Checked expressions must be evaluated only once. */
- gnu_expr = protect_multiple_eval (gnu_expr);
+ gnu_expr = gnat_protect_expr (gnu_expr);
/* Must do this computation in the base type in case the expression's
type is an unsigned subtypes. */
&& !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
{
/* Ensure GNU_EXPR only gets evaluated once. */
- tree gnu_input = protect_multiple_eval (gnu_result);
+ tree gnu_input = gnat_protect_expr (gnu_result);
tree gnu_cond = integer_zero_node;
tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
&& !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 = gnat_protect_expr (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;
}
\f
-/* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
-
-tree
-protect_multiple_eval (tree exp)
-{
- tree type = TREE_TYPE (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
- involving checks which will be reused multiple times and eventually be
- unshared for gimplification; in order to avoid a complexity explosion
- at that point, we protect any expressions more complex than a simple
- arithmetic expression. */
- if (!TREE_SIDE_EFFECTS (exp)
- && (CONSTANT_CLASS_P (exp)
- || !EXPRESSION_CLASS_P (skip_simple_arithmetic (exp))))
- return exp;
-
- /* If this is a conversion, protect what's inside the conversion.
- 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)
- return save_expr (exp);
-
- /* Otherwise, reference, protect the address and dereference. */
- return
- build_unary_op (INDIRECT_REF, type,
- save_expr (build_unary_op (ADDR_EXPR,
- build_reference_type (type),
- exp)));
-}
-\f
-/* This is equivalent to stabilize_reference in tree.c, but we know how to
- handle our own nodes and we take extra arguments. FORCE says whether to
- force evaluation of everything. We set SUCCESS to true unless we walk
- through something we don't know how to stabilize. */
-
-tree
-maybe_stabilize_reference (tree ref, bool force, bool *success)
-{
- tree type = TREE_TYPE (ref);
- enum tree_code code = TREE_CODE (ref);
- tree result;
-
- /* Assume we'll success unless proven otherwise. */
- *success = true;
-
- switch (code)
- {
- case CONST_DECL:
- case VAR_DECL:
- case PARM_DECL:
- case RESULT_DECL:
- /* No action is needed in this case. */
- return ref;
-
- case ADDR_EXPR:
- CASE_CONVERT:
- case FLOAT_EXPR:
- case FIX_TRUNC_EXPR:
- case VIEW_CONVERT_EXPR:
- result
- = build1 (code, type,
- maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- success));
- break;
-
- case INDIRECT_REF:
- case UNCONSTRAINED_ARRAY_REF:
- result = build1 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
- force));
- break;
-
- case COMPONENT_REF:
- result = build3 (COMPONENT_REF, type,
- maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- success),
- TREE_OPERAND (ref, 1), NULL_TREE);
- break;
-
- case BIT_FIELD_REF:
- result = build3 (BIT_FIELD_REF, type,
- maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- success),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
- force),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
- force));
- break;
-
- case ARRAY_REF:
- case ARRAY_RANGE_REF:
- result = build4 (code, type,
- maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- success),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
- force),
- 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. */
- result = gnat_stabilize_reference_1 (ref, force);
- break;
-
- case CONSTRUCTOR:
- /* Constructors with 1 element are used extensively to formally
- convert objects to special wrapping types. */
- if (TREE_CODE (type) == RECORD_TYPE
- && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1)
- {
- tree index
- = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index;
- tree value
- = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value;
- result
- = build_constructor_single (type, index,
- gnat_stabilize_reference_1 (value,
- force));
- }
- else
- {
- *success = false;
- return ref;
- }
- break;
-
- case ERROR_MARK:
- ref = error_mark_node;
-
- /* ... fall through to failure ... */
-
- /* If arg isn't a kind of lvalue we recognize, make no change.
- Caller should recognize the error for an invalid lvalue. */
- default:
- *success = false;
- 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.
-
- 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);
- TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
-
- return result;
-}
-
-/* Wrapper around maybe_stabilize_reference, for common uses without
- lvalue restrictions and without need to examine the success
- indication. */
-
-static tree
-gnat_stabilize_reference (tree ref, bool force)
-{
- bool dummy;
- return maybe_stabilize_reference (ref, force, &dummy);
-}
-
-/* Similar to stabilize_reference_1 in tree.c, but supports an extra
- arg to force a SAVE_EXPR for everything. */
-
-static tree
-gnat_stabilize_reference_1 (tree e, bool force)
-{
- enum tree_code code = TREE_CODE (e);
- tree type = TREE_TYPE (e);
- tree result;
-
- /* We cannot ignore const expressions because it might be a reference
- 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:
- /* 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_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));
- 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));
- break;
-
- case tcc_unary:
- /* Recursively stabilize each operand. */
- result = build1 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
- force));
- break;
-
- default:
- gcc_unreachable ();
- }
-
- TREE_READONLY (result) = TREE_READONLY (e);
-
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
- TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
- return result;
-}
-\f
/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
location and false if it doesn't. In the former case, set the Gigi global
variable REF_FILENAME to the simple debug file name as given by sinput. */
OSDN Git Service
