#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 enum gimplify_status gnat_gimplify_stmt (tree *);
static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
-static void process_inlined_subprograms (Node_Id);
static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
static tree emit_range_check (tree, Node_Id, Node_Id);
static tree emit_index_check (tree, tree, tree, tree, Node_Id);
static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
-static bool smaller_packable_type_p (tree, tree);
+static bool smaller_form_type_p (tree, tree);
static bool addressable_p (tree, tree);
static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
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,
struct List_Header *list_headers_ptr, Nat number_file,
- struct File_Info_Type *file_info_ptr, Entity_Id standard_boolean,
- Entity_Id standard_integer, Entity_Id standard_long_long_float,
+ struct File_Info_Type *file_info_ptr,
+ Entity_Id standard_boolean, Entity_Id standard_integer,
+ Entity_Id standard_character, Entity_Id standard_long_long_float,
Entity_Id standard_exception_type, Int gigi_operating_mode)
{
Entity_Id gnat_literal;
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
double_float_alignment = get_target_double_float_alignment ();
double_scalar_alignment = get_target_double_scalar_alignment ();
- /* Record the builtin types. Define `integer' and `unsigned char' first so
- that dbx will output them first. */
+ /* Record the builtin types. Define `integer' and `character' first so that
+ dbx will output them first. */
record_builtin_type ("integer", integer_type_node);
- record_builtin_type ("unsigned char", char_type_node);
- record_builtin_type ("long integer", long_integer_type_node);
- unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
- record_builtin_type ("unsigned int", unsigned_type_node);
- record_builtin_type (SIZE_TYPE, sizetype);
+ record_builtin_type ("character", unsigned_char_type_node);
record_builtin_type ("boolean", boolean_type_node);
record_builtin_type ("void", void_type_node);
/* Save the type we made for integer as the type for Standard.Integer. */
- save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node),
+ save_gnu_tree (Base_Type (standard_integer),
+ TYPE_NAME (integer_type_node),
false);
- /* Save the type we made for boolean as the type for Standard.Boolean. */
- save_gnu_tree (Base_Type (standard_boolean), TYPE_NAME (boolean_type_node),
+ /* Likewise for character as the type for Standard.Character. */
+ save_gnu_tree (Base_Type (standard_character),
+ TYPE_NAME (unsigned_char_type_node),
+ false);
+
+ /* Likewise for boolean as the type for Standard.Boolean. */
+ save_gnu_tree (Base_Type (standard_boolean),
+ TYPE_NAME (boolean_type_node),
false);
gnat_literal = First_Literal (Base_Type (standard_boolean));
t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
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_TREE, false, true, true, NULL, Empty);
/* Avoid creating superfluous edges to __builtin_setjmp receivers. */
DECL_PURE_P (get_jmpbuf_decl) = 1;
+ DECL_IGNORED_P (get_jmpbuf_decl) = 1;
set_jmpbuf_decl
= create_subprog_decl
build_function_type (void_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
NULL_TREE, false, true, true, NULL, Empty);
+ DECL_IGNORED_P (set_jmpbuf_decl) = 1;
/* setjmp returns an integer and has one operand, which is a pointer to
a jmpbuf. */
build_function_type (integer_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
NULL_TREE, false, true, true, NULL, Empty);
-
DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
build_function_type (void_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
NULL_TREE, false, true, true, NULL, Empty);
-
DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
ptr_void_type_node,
t)),
NULL_TREE, false, true, true, NULL, Empty);
+ DECL_IGNORED_P (begin_handler_decl) = 1;
end_handler_decl
= create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
ptr_void_type_node,
t)),
NULL_TREE, false, true, true, NULL, Empty);
+ DECL_IGNORED_P (end_handler_decl) = 1;
/* If in no exception handlers mode, all raise statements are redirected to
__gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
(get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE,
- build_pointer_type (char_type_node),
+ build_pointer_type
+ (unsigned_char_type_node),
tree_cons (NULL_TREE,
integer_type_node,
t))),
build_function_type (void_type_node,
tree_cons (NULL_TREE,
build_pointer_type
- (char_type_node),
+ (unsigned_char_type_node),
tree_cons (NULL_TREE,
integer_type_node,
t))),
TYPE_QUAL_VOLATILE);
}
- /* Set the types that GCC and Gigi use from the front end. We would
- like to do this for char_type_node, but it needs to correspond to
- the C char type. */
+ /* Set the types that GCC and Gigi use from the front end. */
exception_type
= gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
except_type_node = TREE_TYPE (exception_type);
for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
{
- tree field = create_field_decl (NULL_TREE, ptr_void_ftype,
- fdesc_type_node, 0, 0, 0, 1);
+ tree field
+ = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
+ NULL_TREE, NULL_TREE, 0, 1);
TREE_CHAIN (field) = field_list;
field_list = field;
null_list = tree_cons (field, null_node, null_list);
gnat_init_gcc_eh ();
/* Now translate the compilation unit proper. */
- start_stmt_group ();
Compilation_Unit_to_gnu (gnat_root);
/* Finally see if we have any elaboration procedures to deal with. */
error_gnat_node = Empty;
}
\f
+/* 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, ALIASED whether it is aliased (but the latter
- doesn't affect the outcome if CONSTANT is not true).
+ 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.
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:
case N_Procedure_Call_Statement:
- return (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type));
+ /* If the parameter is by reference, an lvalue is required. */
+ return (!constant
+ || must_pass_by_ref (gnu_type)
+ || default_pass_by_ref (gnu_type));
case N_Indexed_Component:
/* Only the array expression can require an lvalue. */
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 (!constant
+ ||(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 (Name (gnat_parent) == gnat_node
+ return (!constant
+ || Name (gnat_parent) == gnat_node
|| (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:
- /* Returning 0 is very likely correct but we get better code if we
- go through the conversion. */
- return lvalue_required_p (gnat_parent,
- get_unpadded_type (Etype (gnat_parent)),
- constant, aliased);
+ return (!constant
+ || 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;
}
gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
}
- /* If we have a constant declaration and its initializer at hand,
- try to return the latter to avoid the need to call fold in lots
- of places and the need of elaboration code if this Id is used as
- an initializer itself. */
+ /* If we have a constant declaration and its initializer, try to return the
+ latter to avoid the need to call fold in lots of places and the need for
+ elaboration code if this identifier is used as an initializer itself. */
if (TREE_CONSTANT (gnu_result)
&& 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));
+
+ /* ??? We need to unshare the initializer if the object is external
+ as such objects are not marked for unsharing if we are not at the
+ global level. This should be fixed in add_decl_expr. */
+ if ((constant_only && !address_of_constant) || !require_lvalue)
gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
}
*gnu_result_type_p = gnu_result_type;
+
return gnu_result;
}
\f
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,
+ (build_binary_op (EQ_EXPR, boolean_type_node,
gnu_expr,
attribute == Attr_Pred
? TYPE_MIN_VALUE (gnu_result_type)
if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
{
- tree gnu_char_ptr_type = build_pointer_type (char_type_node);
+ tree gnu_char_ptr_type
+ = build_pointer_type (unsigned_char_type_node);
tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
- tree gnu_byte_offset
- = convert (sizetype,
- size_diffop (size_zero_node, gnu_pos));
- gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
-
gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
- gnu_ptr, gnu_byte_offset);
+ gnu_ptr, gnu_pos);
}
gnu_result = convert (gnu_result_type, gnu_ptr);
gnu_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
- get_identifier ("SIZE"));
+ get_identifier ("SIZE"),
+ false);
}
gnu_result = TYPE_SIZE (gnu_type);
else
gnu_result = rm_size (gnu_type);
- gcc_assert (gnu_result);
-
/* Deal with a self-referential size by returning the maximum size for
- a type and by qualifying the size with the object for 'Size of an
- object. */
+ a type and by qualifying the size with the object otherwise. */
if (CONTAINS_PLACEHOLDER_P (gnu_result))
{
- if (TREE_CODE (gnu_prefix) != TYPE_DECL)
- gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
- else
+ if (TREE_CODE (gnu_prefix) == TYPE_DECL)
gnu_result = max_size (gnu_result, true);
+ else
+ gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
}
/* If the type contains a template, subtract its size. */
gnu_result = size_binop (MINUS_EXPR, gnu_result,
DECL_SIZE (TYPE_FIELDS (gnu_type)));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
+ /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
if (attribute == Attr_Max_Size_In_Storage_Elements)
- gnu_result = fold_build2 (CEIL_DIV_EXPR, bitsizetype,
- gnu_result, bitsize_unit_node);
+ gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
break;
case Attr_Alignment:
gnu_result
= build_cond_expr (comp_type,
build_binary_op (GE_EXPR,
- integer_type_node,
+ boolean_type_node,
hb, lb),
gnu_result,
convert (comp_type, integer_zero_node));
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,
return gnu_result;
}
\f
+/* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
+ false, or the maximum value if MAX is true, of TYPE. */
+
+static bool
+can_equal_min_or_max_val_p (tree val, tree type, bool max)
+{
+ tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
+
+ if (TREE_CODE (min_or_max_val) != INTEGER_CST)
+ return true;
+
+ if (TREE_CODE (val) == NOP_EXPR)
+ val = (max
+ ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
+ : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
+
+ if (TREE_CODE (val) != INTEGER_CST)
+ return true;
+
+ return tree_int_cst_equal (val, min_or_max_val) == 1;
+}
+
+/* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
+ If REVERSE is true, minimum value is taken as maximum value. */
+
+static inline bool
+can_equal_min_val_p (tree val, tree type, bool reverse)
+{
+ return can_equal_min_or_max_val_p (val, type, reverse);
+}
+
+/* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
+ If REVERSE is true, maximum value is taken as minimum value. */
+
+static inline bool
+can_equal_max_val_p (tree val, tree type, bool reverse)
+{
+ return can_equal_min_or_max_val_p (val, type, !reverse);
+}
+
/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
to a GCC tree, which is returned. */
static tree
Loop_Statement_to_gnu (Node_Id gnat_node)
{
- /* ??? It would be nice to use "build" here, but there's no build5. */
- tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
- NULL_TREE, NULL_TREE, NULL_TREE);
- tree gnu_loop_var = NULL_TREE;
- Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
- tree gnu_cond_expr = NULL_TREE;
+ const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
+ tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
+ NULL_TREE, NULL_TREE, NULL_TREE);
+ tree gnu_loop_label = create_artificial_label (input_location);
+ tree gnu_loop_var = NULL_TREE, gnu_cond_expr = NULL_TREE;
tree gnu_result;
- TREE_TYPE (gnu_loop_stmt) = void_type_node;
- TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
- LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (input_location);
+ /* Set location information for statement and end label. */
set_expr_location_from_node (gnu_loop_stmt, gnat_node);
Sloc_to_locus (Sloc (End_Label (gnat_node)),
- &DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt)));
+ &DECL_SOURCE_LOCATION (gnu_loop_label));
+ LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
- /* Save the end label of this LOOP_STMT in a stack so that the corresponding
+ /* Save the end label of this LOOP_STMT in a stack so that a corresponding
N_Exit_Statement can find it. */
- push_stack (&gnu_loop_label_stack, NULL_TREE,
- LOOP_STMT_LABEL (gnu_loop_stmt));
+ push_stack (&gnu_loop_label_stack, NULL_TREE, gnu_loop_label);
/* Set the condition under which the loop must keep going.
For the case "LOOP .... END LOOP;" the condition is always true. */
/* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
else if (Present (Condition (gnat_iter_scheme)))
- LOOP_STMT_TOP_COND (gnu_loop_stmt)
+ LOOP_STMT_COND (gnu_loop_stmt)
= gnat_to_gnu (Condition (gnat_iter_scheme));
- /* Otherwise we have an iteration scheme and the condition is given by
- the bounds of the subtype of the iteration variable. */
+ /* Otherwise we have an iteration scheme and the condition is given by the
+ bounds of the subtype of the iteration variable. */
else
{
Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
tree gnu_type = get_unpadded_type (gnat_type);
tree gnu_low = TYPE_MIN_VALUE (gnu_type);
tree gnu_high = TYPE_MAX_VALUE (gnu_type);
- tree gnu_first, gnu_last, gnu_limit;
- enum tree_code update_code, end_code;
tree gnu_base_type = get_base_type (gnu_type);
+ tree gnu_one_node = convert (gnu_base_type, integer_one_node);
+ tree gnu_first, gnu_last;
+ enum tree_code update_code, test_code, shift_code;
+ bool reverse = Reverse_Present (gnat_loop_spec), fallback = false;
- /* We must disable modulo reduction for the loop variable, if any,
+ /* We must disable modulo reduction for the iteration variable, if any,
in order for the loop comparison to be effective. */
- if (Reverse_Present (gnat_loop_spec))
+ if (reverse)
{
gnu_first = gnu_high;
gnu_last = gnu_low;
update_code = MINUS_NOMOD_EXPR;
- end_code = GE_EXPR;
- gnu_limit = TYPE_MIN_VALUE (gnu_base_type);
+ test_code = GE_EXPR;
+ shift_code = PLUS_NOMOD_EXPR;
}
else
{
gnu_first = gnu_low;
gnu_last = gnu_high;
update_code = PLUS_NOMOD_EXPR;
- end_code = LE_EXPR;
- gnu_limit = TYPE_MAX_VALUE (gnu_base_type);
+ test_code = LE_EXPR;
+ shift_code = MINUS_NOMOD_EXPR;
+ }
+
+ /* We use two different strategies to translate the loop, depending on
+ whether optimization is enabled.
+
+ If it is, we try to generate the canonical form of loop expected by
+ the loop optimizer, which is the do-while form:
+
+ ENTRY_COND
+ loop:
+ TOP_UPDATE
+ BODY
+ BOTTOM_COND
+ GOTO loop
+
+ This makes it possible to bypass loop header copying and to turn the
+ BOTTOM_COND into an inequality test. This should catch (almost) all
+ loops with constant starting point. If we cannot, we try to generate
+ the default form, which is:
+
+ loop:
+ TOP_COND
+ BODY
+ BOTTOM_UPDATE
+ GOTO loop
+
+ It will be rotated during loop header copying and an entry test added
+ to yield the do-while form. This should catch (almost) all loops with
+ constant ending point. If we cannot, we generate the fallback form:
+
+ ENTRY_COND
+ loop:
+ BODY
+ BOTTOM_COND
+ BOTTOM_UPDATE
+ GOTO loop
+
+ which works in all cases but for which loop header copying will copy
+ the BOTTOM_COND, thus adding a third conditional branch.
+
+ If optimization is disabled, loop header copying doesn't come into
+ play and we try to generate the loop forms with the less conditional
+ branches directly. First, the default form, it should catch (almost)
+ all loops with constant ending point. Then, if we cannot, we try to
+ generate the shifted form:
+
+ loop:
+ TOP_COND
+ TOP_UPDATE
+ BODY
+ GOTO loop
+
+ which should catch loops with constant starting point. Otherwise, if
+ we cannot, we generate the fallback form. */
+
+ if (optimize)
+ {
+ /* We can use the do-while form if GNU_FIRST-1 doesn't overflow. */
+ if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
+ {
+ gnu_first = build_binary_op (shift_code, gnu_base_type,
+ gnu_first, gnu_one_node);
+ LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
+ LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
+ }
+
+ /* Otherwise, we can use the default form if GNU_LAST+1 doesn't. */
+ else if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
+ ;
+
+ /* Otherwise, use the fallback form. */
+ else
+ fallback = true;
}
+ else
+ {
+ /* We can use the default form if GNU_LAST+1 doesn't overflow. */
+ if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
+ ;
+
+ /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
+ GNU_LAST-1 does. */
+ else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
+ && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
+ {
+ gnu_first = build_binary_op (shift_code, gnu_base_type,
+ gnu_first, gnu_one_node);
+ gnu_last = build_binary_op (shift_code, gnu_base_type,
+ gnu_last, gnu_one_node);
+ LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
+ }
- /* We know the loop variable will not overflow if GNU_LAST is a constant
- and is not equal to GNU_LIMIT. If it might overflow, we have to move
- the limit test to the end of the loop. In that case, we have to test
- for an empty loop outside the loop. */
- if (TREE_CODE (gnu_last) != INTEGER_CST
- || TREE_CODE (gnu_limit) != INTEGER_CST
- || tree_int_cst_equal (gnu_last, gnu_limit))
+ /* Otherwise, use the fallback form. */
+ else
+ fallback = true;
+ }
+
+ if (fallback)
+ LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
+
+ /* If we use the BOTTOM_COND, we can turn the test into an inequality
+ test but we have to add an ENTRY_COND to protect the empty loop. */
+ if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
{
+ test_code = NE_EXPR;
gnu_cond_expr
= build3 (COND_EXPR, void_type_node,
- build_binary_op (LE_EXPR, integer_type_node,
+ build_binary_op (LE_EXPR, boolean_type_node,
gnu_low, gnu_high),
NULL_TREE, alloc_stmt_list ());
set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
}
/* Open a new nesting level that will surround the loop to declare the
- loop index variable. */
+ iteration variable. */
start_stmt_group ();
gnat_pushlevel ();
- /* Declare the loop index and set it to its initial value. */
+ /* Declare the iteration variable and set it to its initial value. */
gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
if (DECL_BY_REF_P (gnu_loop_var))
gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
- /* The loop variable might be a padded type, so use `convert' to get a
- reference to the inner variable if so. */
- gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
+ /* Do all the arithmetics in the base type. */
+ gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
- /* Set either the top or bottom exit condition as appropriate depending
- on whether or not we know an overflow cannot occur. */
- if (gnu_cond_expr)
- LOOP_STMT_BOT_COND (gnu_loop_stmt)
- = build_binary_op (NE_EXPR, integer_type_node,
- gnu_loop_var, gnu_last);
- else
- LOOP_STMT_TOP_COND (gnu_loop_stmt)
- = build_binary_op (end_code, integer_type_node,
- gnu_loop_var, gnu_last);
+ /* Set either the top or bottom exit condition. */
+ LOOP_STMT_COND (gnu_loop_stmt)
+ = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
+ gnu_last);
+ /* Set either the top or bottom update statement and give it the source
+ location of the iteration for better coverage info. */
LOOP_STMT_UPDATE (gnu_loop_stmt)
- = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_loop_var,
- build_binary_op (update_code,
- TREE_TYPE (gnu_loop_var),
- gnu_loop_var,
- convert (TREE_TYPE (gnu_loop_var),
- integer_one_node)));
+ = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
+ build_binary_op (update_code, gnu_base_type,
+ gnu_loop_var, gnu_one_node));
set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
gnat_iter_scheme);
}
/* If the loop was named, have the name point to this loop. In this case,
- the association is not a ..._DECL node, but the end label from this
- LOOP_STMT. */
+ the association is not a DECL node, but the end label of the loop. */
if (Present (Identifier (gnat_node)))
- save_gnu_tree (Entity (Identifier (gnat_node)),
- LOOP_STMT_LABEL (gnu_loop_stmt), true);
+ save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
/* Make the loop body into its own block, so any allocated storage will be
released every iteration. This is needed for stack allocation. */
LOOP_STMT_BODY (gnu_loop_stmt)
= build_stmt_group (Statements (gnat_node), true);
+ TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
/* If we declared a variable, then we are in a statement group for that
declaration. Add the LOOP_STMT to it and make that the "loop". */
gnat_vms_condition_handler_decl
= create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
NULL_TREE,
- build_function_type_list (integer_type_node,
+ build_function_type_list (boolean_type_node,
ptr_void_type_node,
ptr_void_type_node,
NULL_TREE),
allocate_struct_function (gnu_subprog_decl, false);
DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
= GGC_CNEW (struct language_function);
+ set_cfun (NULL);
begin_subprog_body (gnu_subprog_decl);
- gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
/* If there are Out parameters, we need to ensure that the return statement
properly copies them out. We do this by making a new block and converting
any inner return into a goto to a label at the end of the block. */
+ gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
push_stack (&gnu_return_label_stack, NULL_TREE,
gnu_cico_list ? create_artificial_label (input_location)
: NULL_TREE);
/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
- If GNU_TARGET is non-null, this must be a function call and the result
- of the call is to be placed into that object. */
+ If GNU_TARGET is non-null, this must be a function call on the RHS of a
+ N_Assignment_Statement and the result is to be placed into that object. */
static tree
call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
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;
+ VEC(tree,gc) *gnu_actual_vec = NULL;
tree gnu_name_list = NULL_TREE;
tree gnu_before_list = NULL_TREE;
tree gnu_after_list = NULL_TREE;
tree gnu_call;
+ bool went_into_elab_proc = false;
gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
else
gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
+ /* If we are translating a statement, open a new nesting level that will
+ surround it to declare the temporaries created for the call. */
+ if (Nkind (gnat_node) == N_Procedure_Call_Statement || gnu_target)
+ {
+ start_stmt_group ();
+ gnat_pushlevel ();
+ }
+
+ /* The lifetime of the temporaries created for the call ends with the call
+ so we can give them the scope of the elaboration routine at top level. */
+ else if (!current_function_decl)
+ {
+ current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
+ went_into_elab_proc = true;
+ }
+
/* 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
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)
??? 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
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
&& !addressable_p (gnu_name, gnu_name_type))
{
- tree gnu_copy = gnu_name;
+ tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
+
+ /* Do not issue warnings for CONSTRUCTORs since this is not a copy
+ but sort of an instantiation for them. */
+ if (TREE_CODE (gnu_name) == CONSTRUCTOR)
+ ;
- /* 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);
+ /* If the type is passed by reference, a copy is not allowed. */
+ else if (TREE_ADDRESSABLE (gnu_formal_type))
+ 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
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
;
- /* Otherwise remove unpadding from the object and reset the copy. */
+ /* Otherwise remove the unpadding from all the objects. */
else if (TREE_CODE (gnu_name) == COMPONENT_REF
&& TYPE_IS_PADDING_P
(TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
- gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
+ gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
- /* Otherwise convert to the nominal type of the object if it's
- a record type. There are several cases in which we need to
- make the temporary using this type instead of the actual type
- of the object if they are distinct, because the expectations
- of the callee would otherwise not be met:
+ /* Otherwise convert to the nominal type of the object if needed.
+ There are several cases in which we need to make the temporary
+ using this type instead of the actual type of the object when
+ they are distinct, because the expectations of the callee would
+ otherwise not be met:
- if it's a justified modular type,
- - if the actual type is a smaller packable version of it. */
- else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
- && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
- || smaller_packable_type_p (TREE_TYPE (gnu_name),
- gnu_name_type)))
+ - if the actual type is a smaller form of it,
+ - if it's a smaller form of the actual type. */
+ else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
+ && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
+ || smaller_form_type_p (TREE_TYPE (gnu_name),
+ gnu_name_type)))
+ || (INTEGRAL_TYPE_P (gnu_name_type)
+ && smaller_form_type_p (gnu_name_type,
+ TREE_TYPE (gnu_name))))
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. 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;
+ /* Create an explicit temporary holding the copy. This ensures that
+ its lifetime is as narrow as possible around a statement. */
+ gnu_temp = create_var_decl (create_tmp_var_name ("A"), NULL_TREE,
+ TREE_TYPE (gnu_name), NULL_TREE, false,
+ false, false, false, NULL, Empty);
+ DECL_ARTIFICIAL (gnu_temp) = 1;
+ DECL_IGNORED_P (gnu_temp) = 1;
+
+ /* But initialize it on the fly like for an implicit temporary as
+ we aren't necessarily dealing with a statement. */
+ gnu_stmt
+ = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_name);
+ set_expr_location_from_node (gnu_stmt, gnat_actual);
+
+ /* From now on, the real object is the temporary. */
+ gnu_name = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_name), gnu_stmt,
+ gnu_temp);
/* 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,
- gnu_name);
- set_expr_location_from_node (stmt, gnat_node);
- append_to_statement_list (stmt, &gnu_after_list);
+ gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
+ gnu_temp);
+ set_expr_location_from_node (gnu_stmt, gnat_node);
+ append_to_statement_list (gnu_stmt, &gnu_after_list);
}
}
So do it here for the part we will use as an input, if any. */
if (Ekind (gnat_formal) != E_Out_Parameter
&& 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. */
- 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);
- if (TREE_CODE (gnu_actual) != SAVE_EXPR)
- gnu_actual = convert (gnu_formal_type, 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);
/* Unless this is an In parameter, we must remove any justified modular
building from GNU_NAME to get an lvalue. */
&& 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 need not be copied in.
- Otherwise, first see if the PARM_DECL is passed by reference. */
+ Otherwise, first see if the parameter is passed by reference. */
if (gnu_formal
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_REF_P (gnu_formal))
gnu_actual = gnu_name;
/* If we have a padded type, be sure we've removed padding. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
- && TREE_CODE (gnu_actual) != SAVE_EXPR)
+ if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
gnu_actual);
and takes its address. */
if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
- && TREE_CODE (gnu_actual) != SAVE_EXPR
&& Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
&& Is_Array_Type (Etype (gnat_actual)))
gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
gnu_actual);
}
+ /* There is no need to convert the actual to the formal's type before
+ taking its address. The only exception is for unconstrained array
+ types because of the way we build fat pointers. */
+ else if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
+
/* The symmetry of the paths to the type of an entity is broken here
since arguments don't know that they will be passed by ref. */
gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
possibility that the ARRAY_REF might return a constant and we'd be
getting the wrong address. Neither approach is exactly correct,
but this is the most likely to work in all cases. */
- gnu_actual = convert (gnu_formal_type,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_actual));
+ gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
}
else if (gnu_formal
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_DESCRIPTOR_P (gnu_formal))
{
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
+
/* If this is 'Null_Parameter, pass a zero descriptor. */
if ((TREE_CODE (gnu_actual) == INDIRECT_REF
|| TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
- continue;
+ {
+ /* 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;
+ }
+
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
/* If this is 'Null_Parameter, pass a zero even though we are
dereferencing it. */
gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
}
- gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
+ VEC_safe_push (tree, gc, gnu_actual_vec, gnu_actual);
}
gnu_call = build_call_list (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr,
if (Nkind (gnat_node) == N_Function_Call)
{
tree gnu_result = gnu_call;
- enum tree_code op_code;
/* If the function returns an unconstrained array or by direct reference,
we have to dereference the pointer. */
if (gnu_target)
{
+ Node_Id gnat_parent = Parent (gnat_node);
+ enum tree_code op_code;
+
+ /* If range check is needed, emit code to generate it. */
+ if (Do_Range_Check (gnat_node))
+ gnu_result
+ = emit_range_check (gnu_result, Etype (Name (gnat_parent)),
+ gnat_parent);
+
/* ??? 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. */
gnu_result
= build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result);
+ add_stmt_with_node (gnu_result, gnat_parent);
+ gnat_poplevel ();
+ gnu_result = end_stmt_group ();
}
else
- *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
+ {
+ if (went_into_elab_proc)
+ current_function_decl = NULL_TREE;
+ *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
+ }
return gnu_result;
}
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 scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
- int length = list_length (scalar_return_list);
+ /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
+ copy-out parameters. */
+ tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
+ const int length = list_length (gnu_cico_list);
if (length > 1)
{
- tree gnu_name;
+ tree gnu_temp, gnu_stmt;
/* 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);
+ the function is pure. Save the result into a temporary. */
+ gnu_temp = create_var_decl (create_tmp_var_name ("R"), NULL_TREE,
+ TREE_TYPE (gnu_call), NULL_TREE, false,
+ false, false, false, NULL, Empty);
+ DECL_ARTIFICIAL (gnu_temp) = 1;
+ DECL_IGNORED_P (gnu_temp) = 1;
+
+ gnu_stmt
+ = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_call);
+ set_expr_location_from_node (gnu_stmt, gnat_node);
- /* 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);
+ /* Add the call statement to the list and start from its result. */
+ append_to_statement_list (gnu_stmt, &gnu_before_list);
+ gnu_call = gnu_temp;
+
+ gnu_name_list = nreverse (gnu_name_list);
}
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
= length == 1
? gnu_call
: build_component_ref (gnu_call, NULL_TREE,
- TREE_PURPOSE (scalar_return_list),
- false);
+ TREE_PURPOSE (gnu_cico_list), false);
/* If the actual is a conversion, get the inner expression, which
will be the real destination, and convert the result to 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);
append_to_statement_list (gnu_result, &gnu_before_list);
- scalar_return_list = TREE_CHAIN (scalar_return_list);
+ gnu_cico_list = TREE_CHAIN (gnu_cico_list);
gnu_name_list = TREE_CHAIN (gnu_name_list);
}
}
append_to_statement_list (gnu_after_list, &gnu_before_list);
- return gnu_before_list;
+ add_stmt (gnu_before_list);
+ gnat_poplevel ();
+ return end_stmt_group ();
}
\f
/* Subroutine of gnat_to_gnu to translate gnat_node, an
else
this_choice
= build_binary_op
- (EQ_EXPR, integer_type_node,
+ (EQ_EXPR, boolean_type_node,
convert
(integer_type_node,
build_component_ref
this_choice
= build_binary_op
- (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack),
+ (EQ_EXPR, boolean_type_node, TREE_VALUE (gnu_except_ptr_stack),
convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
this_choice
= build_binary_op
- (TRUTH_ORIF_EXPR, integer_type_node,
- build_binary_op (EQ_EXPR, integer_type_node, gnu_comp,
+ (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp,
build_int_cst (TREE_TYPE (gnu_comp), 'V')),
this_choice);
}
else
gcc_unreachable ();
- gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
+ gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
gnu_choice, this_choice);
}
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))
{
static void
Compilation_Unit_to_gnu (Node_Id gnat_node)
{
+ const Node_Id gnat_unit = Unit (gnat_node);
+ const bool body_p = (Nkind (gnat_unit) == N_Package_Body
+ || Nkind (gnat_unit) == N_Subprogram_Body);
+ const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
/* Make the decl for the elaboration procedure. */
- bool body_p = (Defining_Entity (Unit (gnat_node)),
- Nkind (Unit (gnat_node)) == N_Package_Body
- || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
- Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
tree gnu_elab_proc_decl
= create_subprog_decl
- (create_concat_name (gnat_unit_entity,
- body_p ? "elabb" : "elabs"),
- NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
- gnat_unit_entity);
+ (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
+ NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, gnat_unit);
struct elab_info *info;
push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
-
DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
+
+ /* Initialize the information structure for the function. */
allocate_struct_function (gnu_elab_proc_decl, false);
- Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
set_cfun (NULL);
+ current_function_decl = NULL_TREE;
+
+ start_stmt_group ();
+ gnat_pushlevel ();
+
+ current_function_decl = NULL_TREE;
+
+ start_stmt_group ();
+ gnat_pushlevel ();
+
/* For a body, first process the spec if there is one. */
if (Nkind (Unit (gnat_node)) == N_Package_Body
|| (Nkind (Unit (gnat_node)) == N_Subprogram_Body
finalize_from_with_types ();
}
- process_inlined_subprograms (gnat_node);
+ /* If we can inline, generate code for all the inlined subprograms. */
+ if (optimize)
+ {
+ Entity_Id gnat_entity;
+
+ for (gnat_entity = First_Inlined_Subprogram (gnat_node);
+ Present (gnat_entity);
+ gnat_entity = Next_Inlined_Subprogram (gnat_entity))
+ {
+ Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
+
+ if (Nkind (gnat_body) != N_Subprogram_Body)
+ {
+ /* ??? This really should always be present. */
+ if (No (Corresponding_Body (gnat_body)))
+ continue;
+ gnat_body
+ = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
+ }
+
+ if (Present (gnat_body))
+ {
+ /* Define the entity first so we set DECL_EXTERNAL. */
+ gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ add_stmt (gnat_to_gnu (gnat_body));
+ }
+ }
+ }
if (type_annotate_only && gnat_node == Cunit (Main_Unit))
{
set_current_block_context (gnu_elab_proc_decl);
gnat_poplevel ();
DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
+
+ Sloc_to_locus
+ (Sloc (gnat_unit),
+ &DECL_STRUCT_FUNCTION (gnu_elab_proc_decl)->function_end_locus);
+
info->next = elab_info_list;
info->elab_proc = gnu_elab_proc_decl;
info->gnat_node = gnat_node;
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)
- && !(Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
+ && !((Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
+ || Nkind (Parent (gnat_node)) == N_Function_Call)
&& Name (Parent (gnat_node)) != gnat_node))
return false;
if (to_type == from_type)
return true;
- /* For an array type, the conversion to the PAT is a no-op. */
+ /* For an array subtype, the conversion to the PAT is a no-op. */
if (Ekind (from_type) == E_Array_Subtype
&& to_type == Packed_Array_Type (from_type))
return true;
+ /* For a record subtype, the conversion to the type is a no-op. */
+ if (Ekind (from_type) == E_Record_Subtype
+ && to_type == Etype (from_type))
+ return true;
+
return false;
}
N_Raise_Constraint_Error));
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
|| (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. */
+ the elaboration procedure, so mark us as being in that procedure. */
if (!current_function_decl)
{
current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
- start_stmt_group ();
- gnat_pushlevel ();
went_into_elab_proc = true;
}
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);
}
(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);
/* Test whether the minimum slice value is too small. */
- gnu_expr_l = build_binary_op (LT_EXPR, integer_type_node,
+ gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
convert (gnu_expr_type,
gnu_min_expr),
convert (gnu_expr_type,
gnu_base_min_expr));
/* Test whether the maximum slice value is too large. */
- gnu_expr_h = build_binary_op (GT_EXPR, integer_type_node,
+ gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
convert (gnu_expr_type,
gnu_max_expr),
convert (gnu_expr_type,
/* Build a slice index check that returns the low bound,
assuming the slice is not empty. */
gnu_expr = emit_check
- (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
+ (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
gnu_expr_l, gnu_expr_h),
gnu_min_expr, CE_Index_Check_Failed, gnat_node);
? 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);
case N_Attribute_Reference:
{
- /* The attribute designator (like an enumeration value). */
- int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
-
- /* The Elab_Spec and Elab_Body attributes are special in that
- Prefix is a unit, not an object with a GCC equivalent. Similarly
- for Elaborated, since that variable isn't otherwise known. */
- if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
- return (create_subprog_decl
- (create_concat_name (Entity (Prefix (gnat_node)),
- attribute == Attr_Elab_Body
- ? "elabb" : "elabs"),
- NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL,
- gnat_node));
-
- gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute);
+ /* The attribute designator. */
+ const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
+
+ /* The Elab_Spec and Elab_Body attributes are special in that Prefix
+ is a unit, not an object with a GCC equivalent. */
+ if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
+ return
+ create_subprog_decl (create_concat_name
+ (Entity (Prefix (gnat_node)),
+ attr == Attr_Elab_Body ? "elabb" : "elabs"),
+ NULL_TREE, void_ftype, NULL_TREE, false,
+ true, true, NULL, gnat_node);
+
+ gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
}
break;
else
{
tree t1, t2;
- gnu_obj = protect_multiple_eval (gnu_obj);
+ 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);
{
enum tree_code code = gnu_codes[kind];
bool ignore_lhs_overflow = false;
+ location_t saved_location = input_location;
tree gnu_type;
gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
gnu_result = build_binary_op_trapv (code, gnu_type,
gnu_lhs, gnu_rhs, gnat_node);
else
- gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
+ {
+ /* Some operations, e.g. comparisons of arrays, generate complex
+ trees that need to be annotated while they are being built. */
+ input_location = saved_location;
+ gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
+ }
/* If this is a logical shift with the shift count not verified,
we must return zero if it is too large. We cannot compensate
gnu_result
= build_cond_expr
(gnu_type,
- build_binary_op (GE_EXPR, integer_type_node,
+ build_binary_op (GE_EXPR, boolean_type_node,
gnu_rhs,
convert (TREE_TYPE (gnu_rhs),
TYPE_SIZE (gnu_type))),
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:
/* Get the LHS and RHS of the statement and convert any reference to an
- unconstrained array into a reference to the underlying array.
- If we are not to do range checking and the RHS is an N_Function_Call,
- pass the LHS to the call function. */
+ unconstrained array into a reference to the underlying array. */
gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
/* If the type has a size that overflows, convert this into raise of
&& TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
N_Raise_Storage_Error);
- else if (Nkind (Expression (gnat_node)) == N_Function_Call
- && !Do_Range_Check (Expression (gnat_node)))
- gnu_result = call_to_gnu (Expression (gnat_node),
- &gnu_result_type, gnu_lhs);
+ else if (Nkind (Expression (gnat_node)) == N_Function_Call)
+ gnu_result
+ = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs);
else
{
gnu_rhs
gnu_result
= build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
- /* If the type being assigned is an array type and the two sides
- are not completely disjoint, play safe and use memmove. */
+ /* If the type being assigned is an array type and the two sides are
+ not completely disjoint, play safe and use memmove. But don't do
+ it for a bit-packed array as it might not be byte-aligned. */
if (TREE_CODE (gnu_result) == MODIFY_EXPR
&& Is_Array_Type (Etype (Name (gnat_node)))
+ && !Is_Bit_Packed_Array (Etype (Name (gnat_node)))
&& !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
{
tree to, from, size, to_ptr, from_ptr, t;
{
gnu_result = build1 (GOTO_EXPR, void_type_node,
TREE_VALUE (gnu_return_label_stack));
+ /* When not optimizing, make sure the return is preserved. */
+ if (!optimize && Comes_From_Source (gnat_node))
+ DECL_ARTIFICIAL (TREE_VALUE (gnu_return_label_stack)) = 0;
break;
}
/*********************************************************/
case N_Compilation_Unit:
-
- /* This is not called for the main unit, which is handled in function
- gigi above. */
- start_stmt_group ();
- gnat_pushlevel ();
-
+ /* This is not called for the main unit on which gigi is invoked. */
Compilation_Unit_to_gnu (gnat_node);
gnu_result = alloc_stmt_list ();
break;
gnu_actual_obj_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
- get_identifier ("DEALLOC"));
+ get_identifier
+ ("DEALLOC"));
}
else
gnu_actual_obj_type = gnu_obj_type;
if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
{
- tree gnu_char_ptr_type = build_pointer_type (char_type_node);
+ tree gnu_char_ptr_type
+ = build_pointer_type (unsigned_char_type_node);
tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
- tree gnu_byte_offset
- = convert (sizetype,
- size_diffop (size_zero_node, gnu_pos));
- gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
-
gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
- gnu_ptr, gnu_byte_offset);
+ gnu_ptr, gnu_pos);
}
gnu_result
gnu_result = alloc_stmt_list ();
break;
- case N_SCIL_Dispatch_Table_Object_Init:
- case N_SCIL_Dispatch_Table_Tag_Init:
- case N_SCIL_Dispatching_Call:
- case N_SCIL_Membership_Test:
- case N_SCIL_Tag_Init:
- /* SCIL nodes require no processing for GCC. */
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Raise_Statement:
- case N_Function_Specification:
- case N_Procedure_Specification:
- case N_Op_Concat:
- case N_Component_Association:
- case N_Task_Body:
default:
- gcc_assert (type_annotate_only);
+ /* SCIL nodes require no processing for GCC. Other nodes should only
+ be present when annotating types. */
+ gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only);
gnu_result = alloc_stmt_list ();
}
- /* If we pushed our level as part of processing the elaboration routine,
- pop it back now. */
+ /* If we pushed the processing of the elaboration routine, pop it back. */
if (went_into_elab_proc)
- {
- add_stmt (gnu_result);
- gnat_poplevel ();
- gnu_result = end_stmt_group ();
- current_function_decl = NULL_TREE;
- }
+ current_function_decl = NULL_TREE;
+
+ /* When not optimizing, turn boolean rvalues B into B != false tests
+ so that the code just below can put the location information of the
+ reference to B on the inequality operator for better debug info. */
+ if (!optimize
+ && (kind == N_Identifier
+ || kind == N_Expanded_Name
+ || kind == N_Explicit_Dereference
+ || kind == N_Function_Call
+ || kind == N_Indexed_Component
+ || kind == N_Selected_Component)
+ && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
+ && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
+ gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
+ convert (gnu_result_type, gnu_result),
+ convert (gnu_result_type,
+ boolean_false_node));
/* Set the location information on the result if it is a real expression.
References can be reused for multiple GNAT nodes and they would get
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:
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;
-
- 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);
- return GS_ALL_DONE;
- }
+ /* 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 addr = build_fold_addr_expr (tree_output_constant_def (op));
+ *expr_p = fold_convert (TREE_TYPE (expr), addr);
+ }
- /* If we are taking the address of a SAVE_EXPR, we are typically dealing
- with a misaligned argument to be passed by reference in a subprogram
- call. We cannot let the common gimplifier code perform the creation
- of the temporary and its initialization because, in order to ensure
- that the final copy operation is a store and since the temporary made
- for a SAVE_EXPR is not addressable, it may create another temporary,
- addressable this time, which would break the back copy mechanism for
- an IN OUT parameter. */
- if (TREE_CODE (op) == SAVE_EXPR && !SAVE_EXPR_RESOLVED_P (op))
- {
- tree mod, val = TREE_OPERAND (op, 0);
- tree new_var = create_tmp_var (TREE_TYPE (op), "S");
- TREE_ADDRESSABLE (new_var) = 1;
+ /* 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, val);
- if (EXPR_HAS_LOCATION (val))
- SET_EXPR_LOCATION (mod, EXPR_LOCATION (val));
- gimplify_and_add (mod, pre_p);
- ggc_free (mod);
+ mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
+ gimplify_and_add (mod, pre_p);
- TREE_OPERAND (op, 0) = new_var;
- SAVE_EXPR_RESOLVED_P (op) = 1;
+ TREE_OPERAND (expr, 0) = new_var;
+ recompute_tree_invariant_for_addr_expr (expr);
+ }
- TREE_OPERAND (expr, 0) = new_var;
- recompute_tree_invariant_for_addr_expr (expr);
return GS_ALL_DONE;
}
case LOOP_STMT:
{
tree gnu_start_label = create_artificial_label (input_location);
+ tree gnu_cond = LOOP_STMT_COND (stmt);
+ tree gnu_update = LOOP_STMT_UPDATE (stmt);
tree gnu_end_label = LOOP_STMT_LABEL (stmt);
tree t;
+ /* Build the condition expression from the test, if any. */
+ if (gnu_cond)
+ gnu_cond
+ = build3 (COND_EXPR, void_type_node, gnu_cond, alloc_stmt_list (),
+ build1 (GOTO_EXPR, void_type_node, gnu_end_label));
+
/* Set to emit the statements of the loop. */
*stmt_p = NULL_TREE;
- /* We first emit the start label and then a conditional jump to
- the end label if there's a top condition, then the body of the
- loop, then a conditional branch to the end label, then the update,
- if any, and finally a jump to the start label and the definition
- of the end label. */
+ /* We first emit the start label and then a conditional jump to the
+ end label if there's a top condition, then the update if it's at
+ the top, then the body of the loop, then a conditional jump to
+ the end label if there's a bottom condition, then the update if
+ it's at the bottom, and finally a jump to the start label and the
+ definition of the end label. */
append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
gnu_start_label),
stmt_p);
- if (LOOP_STMT_TOP_COND (stmt))
- append_to_statement_list (build3 (COND_EXPR, void_type_node,
- LOOP_STMT_TOP_COND (stmt),
- alloc_stmt_list (),
- build1 (GOTO_EXPR,
- void_type_node,
- gnu_end_label)),
- stmt_p);
+ if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
+ append_to_statement_list (gnu_cond, stmt_p);
+
+ if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
+ append_to_statement_list (gnu_update, stmt_p);
append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
- if (LOOP_STMT_BOT_COND (stmt))
- append_to_statement_list (build3 (COND_EXPR, void_type_node,
- LOOP_STMT_BOT_COND (stmt),
- alloc_stmt_list (),
- build1 (GOTO_EXPR,
- void_type_node,
- gnu_end_label)),
- stmt_p);
+ if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
+ append_to_statement_list (gnu_cond, stmt_p);
- if (LOOP_STMT_UPDATE (stmt))
- append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p);
+ if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
+ append_to_statement_list (gnu_update, stmt_p);
t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
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 as they are always transformed
- into their root type. */
- if (Ekind (gnat_entity) == E_Class_Wide_Type)
- 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. */
TREE_TYPE (gnu_new));
}
\f
-/* Process the list of inlined subprograms of GNAT_NODE, which is an
- N_Compilation_Unit. */
-
-static void
-process_inlined_subprograms (Node_Id gnat_node)
-{
- Entity_Id gnat_entity;
- Node_Id gnat_body;
-
- /* If we can inline, generate Gimple for all the inlined subprograms.
- Define the entity first so we set DECL_EXTERNAL. */
- if (optimize > 0)
- for (gnat_entity = First_Inlined_Subprogram (gnat_node);
- Present (gnat_entity);
- gnat_entity = Next_Inlined_Subprogram (gnat_entity))
- {
- gnat_body = Parent (Declaration_Node (gnat_entity));
-
- if (Nkind (gnat_body) != N_Subprogram_Body)
- {
- /* ??? This really should always be Present. */
- if (No (Corresponding_Body (gnat_body)))
- continue;
-
- gnat_body
- = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
- }
-
- if (Present (gnat_body))
- {
- gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
- add_stmt (gnat_to_gnu (gnat_body));
- }
- }
-}
-\f
/* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
We make two passes, one to elaborate anything other than bodies (but
we declare a function if there was no spec). The second pass
{
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,
+ return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
operand, TYPE_MIN_VALUE (gnu_type)),
build_unary_op (code, gnu_type, operand),
CE_Overflow_Check_Failed, gnat_node);
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;
}
rhs_lt_zero = tree_expr_nonnegative_p (rhs)
- ? integer_zero_node
- : build_binary_op (LT_EXPR, integer_type_node, rhs, zero);
+ ? boolean_false_node
+ : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
/* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
convert (wide_type, rhs));
tree check = build_binary_op
- (TRUTH_ORIF_EXPR, integer_type_node,
- build_binary_op (LT_EXPR, integer_type_node, wide_result,
+ (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_binary_op (LT_EXPR, boolean_type_node, wide_result,
convert (wide_type, type_min)),
- build_binary_op (GT_EXPR, integer_type_node, wide_result,
+ build_binary_op (GT_EXPR, boolean_type_node, wide_result,
convert (wide_type, type_max)));
tree result = convert (gnu_type, wide_result);
/* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
tree check = build_binary_op
- (TRUTH_XOR_EXPR, integer_type_node, rhs_lt_zero,
+ (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
- integer_type_node, wrapped_expr, lhs));
+ boolean_type_node, wrapped_expr, lhs));
return
emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
{
case PLUS_EXPR:
/* When rhs >= 0, overflow when lhs > type_max - rhs. */
- check_pos = build_binary_op (GT_EXPR, integer_type_node, lhs,
+ check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
build_binary_op (MINUS_EXPR, gnu_type,
type_max, rhs)),
/* When rhs < 0, overflow when lhs < type_min - rhs. */
- check_neg = build_binary_op (LT_EXPR, integer_type_node, lhs,
+ check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
build_binary_op (MINUS_EXPR, gnu_type,
type_min, rhs));
break;
case MINUS_EXPR:
/* When rhs >= 0, overflow when lhs < type_min + rhs. */
- check_pos = build_binary_op (LT_EXPR, integer_type_node, lhs,
+ check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
build_binary_op (PLUS_EXPR, gnu_type,
type_min, rhs)),
/* When rhs < 0, overflow when lhs > type_max + rhs. */
- check_neg = build_binary_op (GT_EXPR, integer_type_node, lhs,
+ check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
build_binary_op (PLUS_EXPR, gnu_type,
type_max, rhs));
break;
tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
- check_pos = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
- build_binary_op (NE_EXPR, integer_type_node, zero, rhs),
- build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
- build_binary_op (GT_EXPR, integer_type_node, lhs, tmp1),
- build_binary_op (LT_EXPR, integer_type_node, lhs, tmp2)));
-
- check_neg = fold_build3 (COND_EXPR, integer_type_node,
- build_binary_op (EQ_EXPR, integer_type_node, rhs,
- build_int_cst (gnu_type, -1)),
- build_binary_op (EQ_EXPR, integer_type_node, lhs, type_min),
- build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
- build_binary_op (GT_EXPR, integer_type_node, lhs, tmp2),
- build_binary_op (LT_EXPR, integer_type_node, lhs, tmp1)));
+ check_pos
+ = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
+ build_binary_op (NE_EXPR, boolean_type_node, zero,
+ rhs),
+ build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_binary_op (GT_EXPR,
+ boolean_type_node,
+ lhs, tmp1),
+ build_binary_op (LT_EXPR,
+ boolean_type_node,
+ lhs, tmp2)));
+
+ check_neg
+ = fold_build3 (COND_EXPR, boolean_type_node,
+ build_binary_op (EQ_EXPR, boolean_type_node, rhs,
+ build_int_cst (gnu_type, -1)),
+ build_binary_op (EQ_EXPR, boolean_type_node, lhs,
+ type_min),
+ build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_binary_op (GT_EXPR,
+ boolean_type_node,
+ lhs, tmp2),
+ build_binary_op (LT_EXPR,
+ boolean_type_node,
+ lhs, tmp1)));
break;
default:
if (TREE_CONSTANT (gnu_expr))
return gnu_expr;
- check = fold_build3 (COND_EXPR, integer_type_node,
- rhs_lt_zero, check_neg, check_pos);
+ check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
+ check_pos);
return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
}
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
+ /* Note that the form of the check is
(not (expr >= lo)) or (not (expr <= hi))
the reason for this slightly convoluted form is that NaNs
are not considered to be in range in the float case. */
return emit_check
- (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
+ (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
invert_truthvalue
- (build_binary_op (GE_EXPR, integer_type_node,
+ (build_binary_op (GE_EXPR, boolean_type_node,
convert (gnu_compare_type, gnu_expr),
convert (gnu_compare_type, gnu_low))),
invert_truthvalue
- (build_binary_op (LE_EXPR, integer_type_node,
+ (build_binary_op (LE_EXPR, boolean_type_node,
convert (gnu_compare_type, gnu_expr),
convert (gnu_compare_type,
gnu_high)))),
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. */
gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
- /* There's no good type to use here, so we might as well use
- integer_type_node. */
return emit_check
- (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
- build_binary_op (LT_EXPR, integer_type_node,
+ (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_binary_op (LT_EXPR, boolean_type_node,
gnu_expr_check,
convert (TREE_TYPE (gnu_expr_check),
gnu_low)),
- build_binary_op (GT_EXPR, integer_type_node,
+ build_binary_op (GT_EXPR, boolean_type_node,
gnu_expr_check,
convert (TREE_TYPE (gnu_expr_check),
gnu_high))),
&& !(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);
: 1))
gnu_cond
= invert_truthvalue
- (build_binary_op (GE_EXPR, integer_type_node,
+ (build_binary_op (GE_EXPR, boolean_type_node,
gnu_input, convert (gnu_in_basetype,
gnu_out_lb)));
TREE_REAL_CST (gnu_in_lb))
: 1))
gnu_cond
- = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
+ = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
invert_truthvalue
- (build_binary_op (LE_EXPR, integer_type_node,
+ (build_binary_op (LE_EXPR, boolean_type_node,
gnu_input,
convert (gnu_in_basetype,
gnu_out_ub))));
conversion of the input to the calc_type (if necessary). */
gnu_zero = convert (gnu_in_basetype, integer_zero_node);
- gnu_result = protect_multiple_eval (gnu_result);
+ 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);
+ = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
gnu_add_pred_half
= fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
gnu_subtract_pred_half
return convert (gnu_type, gnu_result);
}
\f
-/* Return true if TYPE is a smaller packable version of RECORD_TYPE. */
+/* Return true if TYPE is a smaller form of ORIG_TYPE. */
static bool
-smaller_packable_type_p (tree type, tree record_type)
+smaller_form_type_p (tree type, tree orig_type)
{
- tree size, rsize;
+ tree size, osize;
/* We're not interested in variants here. */
- if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (record_type))
+ if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (orig_type))
return false;
/* Like a variant, a packable version keeps the original TYPE_NAME. */
- if (TYPE_NAME (type) != TYPE_NAME (record_type))
+ if (TYPE_NAME (type) != TYPE_NAME (orig_type))
return false;
size = TYPE_SIZE (type);
- rsize = TYPE_SIZE (record_type);
+ osize = TYPE_SIZE (orig_type);
- if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (rsize) == INTEGER_CST))
+ if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (osize) == INTEGER_CST))
return false;
- return tree_int_cst_lt (size, rsize) != 0;
+ return tree_int_cst_lt (size, osize) != 0;
}
/* Return true if GNU_EXPR can be directly addressed. This is the case
static bool
addressable_p (tree gnu_expr, tree gnu_type)
{
- /* The size of the real type of the object must not be smaller than
- that of the expected type, otherwise an indirect access in the
- latter type would be larger than the object. Only records need
- to be considered in practice. */
+ /* For an integral type, the size of the actual type of the object may not
+ be greater than that of the expected type, otherwise an indirect access
+ in the latter type wouldn't correctly set all the bits of the object. */
+ if (gnu_type
+ && INTEGRAL_TYPE_P (gnu_type)
+ && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
+ return false;
+
+ /* The size of the actual type of the object may not be smaller than that
+ of the expected type, otherwise an indirect access in the latter type
+ would be larger than the object. But only record types need to be
+ considered in practice for this case. */
if (gnu_type
&& TREE_CODE (gnu_type) == RECORD_TYPE
- && smaller_packable_type_p (TREE_TYPE (gnu_expr), gnu_type))
+ && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
return false;
switch (TREE_CODE (gnu_expr))
case UNCONSTRAINED_ARRAY_REF:
case INDIRECT_REF:
+ /* Taking the address of a dereference yields the original pointer. */
return true;
- case CONSTRUCTOR:
case STRING_CST:
case INTEGER_CST:
+ /* Taking the address yields a pointer to the constant pool. */
+ return true;
+
+ case CONSTRUCTOR:
+ /* Taking the address of a static constructor yields a pointer to the
+ tree constant pool. */
+ return TREE_STATIC (gnu_expr) ? true : false;
+
case NULL_EXPR:
case SAVE_EXPR:
case CALL_EXPR:
force a temporary to be created by the middle-end. */
return true;
+ case COMPOUND_EXPR:
+ /* The address of a compound expression is that of its 2nd operand. */
+ return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
+
case COND_EXPR:
/* We accept &COND_EXPR as soon as both operands are addressable and
expect the outcome to be the address of the selected operand. */
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);
- enum tree_code code = TREE_CODE (exp);
-
- /* If EXP has no side effects, we theoritically don't need to do anything.
- However, we may be recursively passed more and more complex expressions
- 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 (code == NON_LVALUE_EXPR
- || CONVERT_EXPR_CODE_P (code)
- || code == VIEW_CONVERT_EXPR
- || code == INDIRECT_REF
- || code == UNCONSTRAINED_ARRAY_REF)
- return build1 (code, type, protect_multiple_eval (TREE_OPERAND (exp, 0)));
-
- /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
- This may be more efficient, but will also allow us to more easily find
- the match for the PLACEHOLDER_EXPR. */
- if (code == COMPONENT_REF
- && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
- return build3 (code, type, protect_multiple_eval (TREE_OPERAND (exp, 0)),
- TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
-
- /* If this is a fat pointer or something that can be placed in a register,
- just make a SAVE_EXPR. Likewise for a CALL_EXPR as large objects are
- returned via invisible reference in most ABIs so the temporary will
- directly be filled by the callee. */
- if (TYPE_IS_FAT_POINTER_P (type)
- || TYPE_MODE (type) != BLKmode
- || code == CALL_EXPR)
- return save_expr (exp);
-
- /* Otherwise reference, protect the address and dereference. */
- 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 CALL_EXPR:
- case COMPOUND_EXPR:
- 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_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression
- may not be sustained across some paths, such as the way via build1 for
- INDIRECT_REF. We reset those flags here in the general case, which is
- consistent with the GCC version of this routine.
-
- Special care should be taken regarding TREE_SIDE_EFFECTS, because some
- paths introduce side-effects where there was none initially (e.g. if a
- SAVE_EXPR is built) and we also want to keep track of that. */
- TREE_READONLY (result) = TREE_READONLY (ref);
- TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
-
- return result;
-}
-
-/* Wrapper around maybe_stabilize_reference, for common uses without lvalue
- restrictions and without the 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_declaration:
- case tcc_comparison:
- 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_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
- result
- = build3 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
- TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
- /* If the expression has side-effects, then encase it in a SAVE_EXPR
- so that it will only be evaluated once. */
- /* The tcc_reference and tcc_comparison classes could be handled as
- below, but it is generally faster to only evaluate them once. */
- else if (TREE_SIDE_EFFECTS (e) || force)
- return save_expr (e);
- else
- return e;
- break;
-
- case tcc_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 ();
- }
-
- /* See similar handling in maybe_stabilize_reference. */
- TREE_READONLY (result) = TREE_READONLY (e);
- TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (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. */
\f
/* Post an error message. MSG is the error message, properly annotated.
NODE is the node at which to post the error and the node to use for the
- "&" substitution. */
+ '&' substitution. */
void
post_error (const char *msg, Node_Id node)
Error_Msg_N (fp, node);
}
-/* Similar, but NODE is the node at which to post the error and ENT
- is the node to use for the "&" substitution. */
+/* Similar to post_error, but NODE is the node at which to post the error and
+ ENT is the node to use for the '&' substitution. */
void
post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
Error_Msg_NE (fp, node, ent);
}
-/* Similar, but NODE is the node at which to post the error, ENT is the node
- to use for the "&" substitution, and N is the number to use for the ^. */
+/* Similar to post_error_ne, but NUM is the number to use for the '^'. */
void
-post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
+post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
{
- String_Template temp;
- Fat_Pointer fp;
-
- temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
- fp.Array = msg, fp.Bounds = &temp;
- Error_Msg_Uint_1 = UI_From_Int (n);
-
- if (Present (node))
- Error_Msg_NE (fp, node, ent);
+ Error_Msg_Uint_1 = UI_From_Int (num);
+ post_error_ne (msg, node, ent);
}
\f
-/* Similar to post_error_ne_num, but T is a GCC tree representing the
- number to write. If the tree represents a constant that fits within
- a host integer, the text inside curly brackets in MSG will be output
- (presumably including a '^'). Otherwise that text will not be output
- and the text inside square brackets will be output instead. */
+/* Similar to post_error_ne, but T is a GCC tree representing the number to
+ write. If T represents a constant, the text inside curly brackets in
+ MSG will be output (presumably including a '^'). Otherwise it will not
+ be output and the text inside square brackets will be output instead. */
void
post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
{
- char *newmsg = XALLOCAVEC (char, strlen (msg) + 1);
- String_Template temp = {1, 0};
- Fat_Pointer fp;
+ char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
char start_yes, end_yes, start_no, end_no;
const char *p;
char *q;
- fp.Array = newmsg, fp.Bounds = &temp;
-
- if (host_integerp (t, 1)
-#if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
- &&
- compare_tree_int
- (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
-#endif
- )
+ if (TREE_CODE (t) == INTEGER_CST)
{
- Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
+ Error_Msg_Uint_1 = UI_From_gnu (t);
start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
}
else
start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
- for (p = msg, q = newmsg; *p; p++)
+ for (p = msg, q = new_msg; *p; p++)
{
if (*p == start_yes)
for (p++; *p != end_yes; p++)
*q = 0;
- temp.High_Bound = strlen (newmsg);
- if (Present (node))
- Error_Msg_NE (fp, node, ent);
+ post_error_ne (new_msg, node, ent);
}
-/* Similar to post_error_ne_tree, except that NUM is a second
- integer to write in the message. */
+/* Similar to post_error_ne_tree, but NUM is a second integer to write. */
void
post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
OSDN Git Service
