* *
* 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- *
#include "fe.h"
#include "sinfo.h"
#include "einfo.h"
+#include "gadaint.h"
#include "ada-tree.h"
#include "gigi.h"
#endif
#endif
-extern char *__gnat_to_canonical_file_spec (char *);
-
-int max_gnat_nodes;
-int number_names;
-int number_files;
+/* Pointers to front-end tables accessed through macros. */
struct Node *Nodes_Ptr;
Node_Id *Next_Node_Ptr;
Node_Id *Prev_Node_Ptr;
Char_Code *String_Chars_Ptr;
struct List_Header *List_Headers_Ptr;
-/* Current filename without path. */
-const char *ref_filename;
+/* Highest number in the front-end node table. */
+int max_gnat_nodes;
+
+/* Current node being treated, in case abort called. */
+Node_Id error_gnat_node;
/* True when gigi is being called on an analyzed but unexpanded
tree, and the only purpose of the call is to properly annotate
types with representation information. */
bool type_annotate_only;
+/* Current filename without path. */
+const char *ref_filename;
+
/* When not optimizing, we cache the 'First, 'Last and 'Length attributes
of unconstrained array IN parameters to avoid emitting a great deal of
redundant instructions to recompute them each time. */
/* Map GNAT tree codes to GCC tree codes for simple expressions. */
static enum tree_code gnu_codes[Number_Node_Kinds];
-/* Current node being treated, in case abort called. */
-Node_Id error_gnat_node;
-
static void init_code_table (void);
static void Compilation_Unit_to_gnu (Node_Id);
static void record_code_position (Node_Id);
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, bool, bool);
+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. */
structures and then generates code. */
void
-gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
+gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
int i;
max_gnat_nodes = max_gnat_node;
- number_names = number_name;
- number_files = number_file;
+
Nodes_Ptr = nodes_ptr;
Next_Node_Ptr = next_node_ptr;
Prev_Node_Ptr = prev_node_ptr;
t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
- for (i = 0; i < number_files; i++)
+ for (i = 0; i < number_file; i++)
{
/* Use the identifier table to make a permanent copy of the filename as
the name table gets reallocated after Gigi returns but before all the
int64_type, NULL_TREE),
NULL_TREE, false, true, true, NULL, Empty);
+ /* Name of the _Parent field in tagged record types. */
+ parent_name_id = get_identifier (Get_Name_String (Name_uParent));
+
/* Make the types and functions used for exception processing. */
jmpbuf_type
= build_array_type (gnat_type_for_mode (Pmode, 0),
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. 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. */
+/* Return a positive value if an lvalue is required for GNAT_NODE, which is
+ an N_Attribute_Reference. */
+
+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, bool constant,
- bool aliased)
+ 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
- || id == Attr_Bit_Position
- || id == Attr_Position
- || id == Attr_First_Bit
- || id == Attr_Last_Bit
- || id == Attr_Bit;
- }
+ 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, constant, 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, constant, 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
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
|| (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
&& Is_Atomic (Entity (Name (gnat_parent)))));
+ case N_Type_Conversion:
+ case N_Qualified_Expression:
+ /* We must look through all conversions for composite types because we
+ may need to bypass an intermediate conversion to a narrower record
+ type that is generated for a formal conversion, e.g. the conversion
+ to the root type of a hierarchy of tagged types generated for the
+ formal conversion to the class-wide type. */
+ if (!Is_Composite_Type (Underlying_Type (Etype (gnat_node))))
+ return 0;
+
+ /* ... fall through ... */
+
+ case N_Unchecked_Type_Conversion:
+ return lvalue_required_p (gnat_parent,
+ get_unpadded_type (Etype (gnat_parent)),
+ constant, address_of_constant, aliased);
+
+ case N_Allocator:
+ /* We should only reach here through the N_Qualified_Expression case
+ and, therefore, only for composite types. Force an lvalue since
+ a block-copy to the newly allocated area of memory is made. */
+ return 1;
+
+ 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, true,
- Is_Aliased (gnat_temp));
+ 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, true,
- 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
}
/* 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)
- continue;
+ if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
+ {
+ /* Make sure side-effects are evaluated before the call. */
+ if (TREE_SIDE_EFFECTS (gnu_name))
+ append_to_statement_list (gnu_name, &gnu_before_list);
+ 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)));
+ tree gnu_result = gnu_call;
+ enum tree_code op_code;
- /* 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);
-
- *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. */
if (length > 1)
{
- 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;
- gnu_name = TREE_CHAIN (gnu_name))
- if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
- append_to_statement_list (TREE_VALUE (gnu_name),
- &gnu_before_list);
}
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
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
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
handler can catch, with special cases for others and all others cases.
Each exception type is actually identified by a pointer to the exception
- id, or to a dummy object for "others" and "all others".
-
- Care should be taken to ensure that the control flow impact of "others"
- and "all others" is known to GCC. lang_eh_type_covers is doing the trick
- currently. */
+ id, or to a dummy object for "others" and "all others". */
for (gnat_temp = First (Exception_Choices (gnat_node));
gnat_temp; gnat_temp = Next (gnat_temp))
{
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_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);
}
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);
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 (kind == N_Not_In)
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,
/* 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);
}
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))
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;
}
elaborate_all_entities (Library_Unit (gnat_node));
}
\f
-/* Do the processing of N_Freeze_Entity, GNAT_NODE. */
+/* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
static void
process_freeze_entity (Node_Id gnat_node)
{
- Entity_Id gnat_entity = Entity (gnat_node);
- tree gnu_old;
- tree gnu_new;
- tree gnu_init
- = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
- && present_gnu_tree (Declaration_Node (gnat_entity)))
- ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
+ const Entity_Id gnat_entity = Entity (gnat_node);
+ const Entity_Kind kind = Ekind (gnat_entity);
+ tree gnu_old, gnu_new;
- /* If this is a package, need to generate code for the package. */
- if (Ekind (gnat_entity) == E_Package)
+ /* If this is a package, we need to generate code for the package. */
+ if (kind == E_Package)
{
insert_code_for
- (Parent (Corresponding_Body
- (Parent (Declaration_Node (gnat_entity)))));
+ (Parent (Corresponding_Body
+ (Parent (Declaration_Node (gnat_entity)))));
return;
}
- /* Check for old definition after the above call. This Freeze_Node
- might be for one its Itypes. */
+ /* Don't do anything for class-wide types as they are always transformed
+ into their root type. */
+ if (kind == E_Class_Wide_Type)
+ return;
+
+ /* Check for an old definition. This freeze node might be for an Itype. */
gnu_old
- = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
+ = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
- /* If this entity has an Address representation clause, GNU_OLD is the
+ /* If this entity has an address representation clause, GNU_OLD is the
address, so discard it here. */
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))))
- return;
+ gnu_old = NULL_TREE;
/* Don't do anything for subprograms that may have been elaborated before
- their freeze nodes. This can happen, for example because of an inner call
- in an instance body, or a previous compilation of a spec for inlining
- purposes. */
+ their freeze nodes. This can happen, for example, because of an inner
+ call in an instance body or because of previous compilation of a spec
+ for inlining purposes. */
if (gnu_old
&& ((TREE_CODE (gnu_old) == FUNCTION_DECL
- && (Ekind (gnat_entity) == E_Function
- || Ekind (gnat_entity) == E_Procedure))
- || (gnu_old
- && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
- && Ekind (gnat_entity) == E_Subprogram_Type)))
+ && (kind == E_Function || kind == E_Procedure))
+ || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
+ && kind == E_Subprogram_Type)))
return;
/* If we have a non-dummy type old tree, we have nothing to do, except
aborting if this is the public view of a private type whose full view was
not delayed, as this node was never delayed as it should have been. We
let this happen for concurrent types and their Corresponding_Record_Type,
- however, because each might legitimately be elaborated before it's own
+ however, because each might legitimately be elaborated before its own
freeze node, e.g. while processing the other. */
if (gnu_old
&& !(TREE_CODE (gnu_old) == TYPE_DECL
&& TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
{
- gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+ gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity))
&& No (Freeze_Node (Full_View (gnat_entity))))
|| Is_Concurrent_Type (gnat_entity)
- || (IN (Ekind (gnat_entity), Record_Kind)
+ || (IN (kind, Record_Kind)
&& Is_Concurrent_Record_Type (gnat_entity)));
return;
}
/* Reset the saved tree, if any, and elaborate the object or type for real.
- If there is a full declaration, elaborate it and copy the type to
- GNAT_ENTITY. Likewise if this is the record subtype corresponding to
- a class wide type or subtype. */
+ If there is a full view, elaborate it and use the result. And, if this
+ is the root type of a class-wide type, reuse it for the latter. */
if (gnu_old)
{
save_gnu_tree (gnat_entity, NULL_TREE, false);
- if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity))
- && present_gnu_tree (Full_View (gnat_entity)))
- save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
- if (Present (Class_Wide_Type (gnat_entity))
- && Class_Wide_Type (gnat_entity) != gnat_entity)
+ if (IN (kind, Incomplete_Or_Private_Kind)
+ && Present (Full_View (gnat_entity))
+ && present_gnu_tree (Full_View (gnat_entity)))
+ save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
+ if (IN (kind, Type_Kind)
+ && Present (Class_Wide_Type (gnat_entity))
+ && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
}
- if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
+ if (IN (kind, Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity)))
{
gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
/* The above call may have defined this entity (the simplest example
- of this is when we have a private enumeral type since the bounds
- will have the public view. */
+ of this is when we have a private enumeral type since the bounds
+ will have the public view). */
if (!present_gnu_tree (gnat_entity))
- save_gnu_tree (gnat_entity, gnu_new, false);
- if (Present (Class_Wide_Type (gnat_entity))
- && Class_Wide_Type (gnat_entity) != gnat_entity)
- save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
+ save_gnu_tree (gnat_entity, gnu_new, false);
}
else
- gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
+ {
+ tree gnu_init
+ = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
+ && present_gnu_tree (Declaration_Node (gnat_entity)))
+ ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
+
+ gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
+ }
+
+ if (IN (kind, Type_Kind)
+ && Present (Class_Wide_Type (gnat_entity))
+ && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
+ save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
/* If we've made any pointers to the old version of this type, we
have to update them. */
{
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. */