#include "fe.h"
#include "sinfo.h"
#include "einfo.h"
-#include "gadaint.h"
#include "ada-tree.h"
#include "gigi.h"
#endif
#endif
-/* Pointers to front-end tables accessed through macros. */
+extern char *__gnat_to_canonical_file_spec (char *);
+
+int max_gnat_nodes;
+int number_names;
+int number_files;
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;
-/* 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;
+/* Current filename without path. */
+const char *ref_filename;
/* True when gigi is being called on an analyzed but unexpanded
tree, and the only purpose of the call is to properly annotate
types with representation information. */
bool type_annotate_only;
-/* Current filename without path. */
-const char *ref_filename;
-
/* When not optimizing, we cache the 'First, 'Last and 'Length attributes
of unconstrained array IN parameters to avoid emitting a great deal of
redundant instructions to recompute them each time. */
/* Map GNAT tree codes to GCC tree codes for simple expressions. */
static enum tree_code gnu_codes[Number_Node_Kinds];
+/* Current node being treated, in case abort called. */
+Node_Id error_gnat_node;
+
static void init_code_table (void);
static void Compilation_Unit_to_gnu (Node_Id);
static void record_code_position (Node_Id);
static tree extract_values (tree, tree);
static tree pos_to_constructor (Node_Id, tree, Entity_Id);
static tree maybe_implicit_deref (tree);
+static tree gnat_stabilize_reference (tree, bool);
+static tree gnat_stabilize_reference_1 (tree, bool);
static void set_expr_location_from_node (tree, Node_Id);
-static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
+static int lvalue_required_p (Node_Id, tree, bool, bool);
/* Hooks for debug info back-ends, only supported and used in a restricted set
of configurations. */
structures and then generates code. */
void
-gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
+gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
int i;
max_gnat_nodes = max_gnat_node;
-
+ number_names = number_name;
+ number_files = number_file;
Nodes_Ptr = nodes_ptr;
Next_Node_Ptr = next_node_ptr;
Prev_Node_Ptr = prev_node_ptr;
t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
- for (i = 0; i < number_file; i++)
+ for (i = 0; i < number_files; i++)
{
/* Use the identifier table to make a permanent copy of the filename as
the name table gets reallocated after Gigi returns but before all the
int64_type, NULL_TREE),
NULL_TREE, false, true, true, NULL, Empty);
- /* Name of the _Parent field in tagged record types. */
- parent_name_id = get_identifier (Get_Name_String (Name_uParent));
-
/* Make the types and functions used for exception processing. */
jmpbuf_type
= build_array_type (gnat_type_for_mode (Pmode, 0),
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. 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.
+ is constant in the Ada sense, ALIASED whether it is aliased (but the latter
+ doesn't affect the outcome if CONSTANT is not true).
The function climbs up the GNAT tree starting from the node and returns 1
upon encountering a node that effectively requires an lvalue downstream.
static int
lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
- bool address_of_constant, bool aliased)
+ bool aliased)
{
Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
return 1;
case N_Attribute_Reference:
- return lvalue_required_for_attribute_p (gnat_parent);
+ {
+ 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;
+ }
case N_Parameter_Association:
case N_Function_Call:
return 0;
aliased |= Has_Aliased_Components (Etype (gnat_node));
- return lvalue_required_p (gnat_parent, gnu_type, constant,
- address_of_constant, aliased);
+ return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
case N_Selected_Component:
aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
- return lvalue_required_p (gnat_parent, gnu_type, constant,
- address_of_constant, aliased);
+ return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
case N_Object_Renaming_Declaration:
/* We need to make a real renaming only if the constant object is
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)))
- /* 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);
+ return Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
+ && Is_Atomic (Defining_Entity (gnat_parent));
case N_Assignment_Statement:
/* We cannot use a constructor if the LHS is an atomic object because
|| (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
&& Is_Atomic (Entity (Name (gnat_parent)))));
- case N_Type_Conversion:
- case N_Qualified_Expression:
- /* We must look through all conversions for composite types because we
- may need to bypass an intermediate conversion to a narrower record
- type that is generated for a formal conversion, e.g. the conversion
- to the root type of a hierarchy of tagged types generated for the
- formal conversion to the class-wide type. */
- if (!Is_Composite_Type (Underlying_Type (Etype (gnat_node))))
- return 0;
-
- /* ... fall through ... */
-
case N_Unchecked_Type_Conversion:
+ /* Returning 0 is very likely correct but we get better code if we
+ go through the conversion. */
return lvalue_required_p (gnat_parent,
get_unpadded_type (Etype (gnat_parent)),
- constant, address_of_constant, aliased);
-
- case N_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 ... */
+ constant, aliased);
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,
- false, Is_Aliased (gnat_temp));
+ Is_Aliased (gnat_temp));
use_constant_initializer = !require_lvalue;
}
&& DECL_P (gnu_result)
&& DECL_INITIAL (gnu_result))
{
- bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
- && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
- bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
- && DECL_CONST_ADDRESS_P (gnu_result));
-
- /* If there is a (corresponding) variable or this is the address of a
- constant, we only want to return the initializer if an lvalue isn't
- required. Evaluate this now if we have not already done so. */
- if ((!constant_only || address_of_constant) && require_lvalue < 0)
- require_lvalue
- = lvalue_required_p (gnat_node, gnu_result_type, true,
- address_of_constant, Is_Aliased (gnat_temp));
-
- if ((constant_only && !address_of_constant) || !require_lvalue)
+ 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)
gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
}
if (Do_Range_Check (First (Expressions (gnat_node))))
{
- gnu_expr = gnat_protect_expr (gnu_expr);
+ gnu_expr = protect_multiple_eval (gnu_expr);
gnu_expr
= emit_check
(build_binary_op (EQ_EXPR, integer_type_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_p = true;
+ choices_added++;
}
}
/* 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_p)
+ if (choices_added > 0)
{
add_stmt (build_stmt_group (Statements (gnat_when), true));
add_stmt (build1 (GOTO_EXPR, void_type_node,
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));
- /* 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. */
+ /* 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. */
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, NULL);
+ gnu_name = gnat_stabilize_reference (gnu_name, true);
/* If we are passing a non-addressable parameter by reference, pass the
address of a copy. In the Out or In Out case, set up to copy back
{
tree gnu_copy = gnu_name;
+ /* If the type is by_reference, a copy is not allowed. */
+ if (Is_By_Reference_Type (Etype (gnat_formal)))
+ post_error
+ ("misaligned actual cannot be passed by reference", gnat_actual);
+
+ /* For users of Starlet we issue a warning because the interface
+ apparently assumes that by-ref parameters outlive the procedure
+ invocation. The code still will not work as intended, but we
+ cannot do much better since low-level parts of the back-end
+ would allocate temporaries at will because of the misalignment
+ if we did not do so here. */
+ else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
+ {
+ post_error
+ ("?possible violation of implicit assumption", gnat_actual);
+ post_error_ne
+ ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
+ Entity (Name (gnat_node)));
+ post_error_ne ("?because of misalignment of &", gnat_actual,
+ gnat_formal);
+ }
+
/* If the actual type of the object is already the nominal type,
we have nothing to do, except if the size is self-referential
in which case we'll remove the unpadding below. */
gnu_name_type)))
gnu_name = convert (gnu_name_type, gnu_name);
- /* Make a SAVE_EXPR to force the creation of a temporary. Special
- code in gnat_gimplify_expr ensures that the same temporary is
- used as the object and copied back after the call if needed. */
+ /* 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;
- /* If the type is passed by reference, a copy is not allowed. */
- if (TREE_ADDRESSABLE (gnu_formal_type))
- {
- post_error ("misaligned actual cannot be passed by reference",
- gnat_actual);
-
- /* Avoid the back-end assertion on temporary creation. */
- gnu_name = TREE_OPERAND (gnu_name, 0);
- }
-
- /* For users of Starlet we issue a warning because the interface
- apparently assumes that by-ref parameters outlive the procedure
- invocation. The code still will not work as intended, but we
- cannot do much better since low-level parts of the back-end
- would allocate temporaries at will because of the misalignment
- if we did not do so here. */
- else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
- {
- post_error
- ("?possible violation of implicit assumption", gnat_actual);
- post_error_ne
- ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
- Entity (Name (gnat_node)));
- post_error_ne ("?because of misalignment of &", gnat_actual,
- gnat_formal);
- }
-
/* Set up to move the copy back to the original if needed. */
if (Ekind (gnat_formal) != E_In_Parameter)
{
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);
-
- /* 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
- gnu_actual
- = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
+ gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
+ gnu_actual);
- /* Make sure that the actual is in range of the formal's type. */
- if (Ekind (gnat_formal) != E_Out_Parameter
- && Do_Range_Check (gnat_actual))
- gnu_actual
- = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
+ /* 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);
+ }
+ 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);
+ }
- /* And convert it to this type. */
if (TREE_CODE (gnu_actual) != SAVE_EXPR)
gnu_actual = convert (gnu_formal_type, gnu_actual);
&& TREE_CODE (gnu_name) == CONSTRUCTOR
&& TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
- gnu_name
- = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
+ gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
+ gnu_name);
/* If we have not saved a GCC object for the formal, it means it is an
Out parameter not passed by reference and that need not be copied in.
gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
- {
- /* Make sure side-effects are evaluated before the call. */
- if (TREE_SIDE_EFFECTS (gnu_name))
- append_to_statement_list (gnu_name, &gnu_before_list);
- continue;
- }
+ continue;
/* If this is 'Null_Parameter, pass a zero even though we are
dereferencing it. */
{
/* 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);
+ tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
+ int length = list_length (scalar_return_list);
if (length > 1)
{
+ tree gnu_name;
+
/* The call sequence must contain one and only one call, even though
the function is const or pure. So force a SAVE_EXPR. */
gnu_call = build1 (SAVE_EXPR, TREE_TYPE (gnu_call), gnu_call);
TREE_SIDE_EFFECTS (gnu_call) = 1;
gnu_name_list = nreverse (gnu_name_list);
+
+ /* If any of the names had side-effects, ensure they are all
+ evaluated before the call. */
+ for (gnu_name = gnu_name_list;
+ gnu_name;
+ gnu_name = TREE_CHAIN (gnu_name))
+ if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
+ append_to_statement_list (TREE_VALUE (gnu_name),
+ &gnu_before_list);
}
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
= length == 1
? gnu_call
: build_component_ref (gnu_call, NULL_TREE,
- TREE_PURPOSE (gnu_cico_list), false);
+ TREE_PURPOSE (scalar_return_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_actual, gnu_result);
set_expr_location_from_node (gnu_result, gnat_node);
append_to_statement_list (gnu_result, &gnu_before_list);
- gnu_cico_list = TREE_CHAIN (gnu_cico_list);
+ scalar_return_list = TREE_CHAIN (scalar_return_list);
gnu_name_list = TREE_CHAIN (gnu_name_list);
}
}
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". */
+ 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. */
for (gnat_temp = First (Exception_Choices (gnat_node));
gnat_temp; gnat_temp = Next (gnat_temp))
{
DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
allocate_struct_function (gnu_elab_proc_decl, false);
Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
- current_function_decl = NULL_TREE;
set_cfun (NULL);
- start_stmt_group ();
- gnat_pushlevel ();
/* For a body, first process the spec if there is one. */
if (Nkind (Unit (gnat_node)) == N_Package_Body
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. */
+ the elaboration procedure, so mark us as being in that procedure
+ and push our context. */
if (!current_function_decl)
{
current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
+ 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 = gnat_save_expr (gnu_expr);
+ gnu_expr = maybe_variable (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 = gnat_protect_expr (gnu_min_expr);
- gnu_max_expr = gnat_protect_expr (gnu_max_expr);
+ gnu_min_expr = protect_multiple_eval (gnu_min_expr);
+ gnu_max_expr = protect_multiple_eval (gnu_max_expr);
/* Derive a good type to convert everything to. */
gnu_expr_type = get_base_type (gnu_index_type);
? Designated_Type (Etype
(Prefix (gnat_node)))
: Etype (Prefix (gnat_node))))
- gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL);
+ gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
gnu_result
= build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
(Nkind (Parent (gnat_node))
- == N_Attribute_Reference)
- && lvalue_required_for_attribute_p
- (Parent (gnat_node)));
+ == N_Attribute_Reference));
}
gcc_assert (gnu_result);
else
{
tree t1, t2;
- gnu_obj = gnat_protect_expr (gnu_obj);
+ gnu_obj = protect_multiple_eval (gnu_obj);
t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
if (EXPR_P (t1))
set_expr_location_from_node (t1, gnat_node);
break;
case N_Null_Statement:
- /* 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 ();
+ gnu_result = alloc_stmt_list ();
break;
case N_Assignment_Statement:
/*********************************************************/
case N_Compilation_Unit:
- /* This is not called for the main unit on which gigi is invoked. */
+
+ /* This is not called for the main unit, which is handled in function
+ gigi above. */
+ start_stmt_group ();
+ gnat_pushlevel ();
+
Compilation_Unit_to_gnu (gnat_node);
gnu_result = alloc_stmt_list ();
break;
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:
- /* 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);
+ gcc_assert (type_annotate_only);
gnu_result = alloc_stmt_list ();
}
- /* If we pushed the processing of the elaboration routine, pop it back. */
+ /* If we pushed our level as part of processing the elaboration routine,
+ pop it back now. */
if (went_into_elab_proc)
- current_function_decl = NULL_TREE;
+ {
+ add_stmt (gnu_result);
+ gnat_poplevel ();
+ gnu_result = end_stmt_group ();
+ current_function_decl = NULL_TREE;
+ }
/* 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, NULL);
+ gnu_result = gnat_stabilize_reference (gnu_result, false);
/* 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 (TREE_CODE (op) == CONSTRUCTOR)
+ /* 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 we are taking the address of a constant CONSTRUCTOR, make sure
- it is put into static memory. We know it's going to be read-only
- given the semantics we have and it must be in static memory when
- the reference is in an elaboration procedure. */
- if (TREE_CONSTANT (op))
- {
- tree new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
- TREE_ADDRESSABLE (new_var) = 1;
- gimple_add_tmp_var (new_var);
-
- TREE_READONLY (new_var) = 1;
- TREE_STATIC (new_var) = 1;
- DECL_INITIAL (new_var) = op;
-
- TREE_OPERAND (expr, 0) = new_var;
- recompute_tree_invariant_for_addr_expr (expr);
- }
-
- /* Otherwise explicitly create the local temporary. That's required
- if the type is passed by reference. */
- else
- {
- tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
- TREE_ADDRESSABLE (new_var) = 1;
- gimple_add_tmp_var (new_var);
-
- mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
- gimplify_and_add (mod, pre_p);
+ tree new_var = create_tmp_var (TREE_TYPE (op), "C");
+ TREE_ADDRESSABLE (new_var) = 1;
- TREE_OPERAND (expr, 0) = new_var;
- recompute_tree_invariant_for_addr_expr (expr);
- }
+ 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;
}
elaborate_all_entities (Library_Unit (gnat_node));
}
\f
-/* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
+/* Do the processing of N_Freeze_Entity, GNAT_NODE. */
static void
process_freeze_entity (Node_Id gnat_node)
{
- const Entity_Id gnat_entity = Entity (gnat_node);
- const Entity_Kind kind = Ekind (gnat_entity);
- tree gnu_old, gnu_new;
+ 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;
- /* If this is a package, we need to generate code for the package. */
- if (kind == E_Package)
+ /* If this is a package, need to generate code for the package. */
+ if (Ekind (gnat_entity) == E_Package)
{
insert_code_for
- (Parent (Corresponding_Body
- (Parent (Declaration_Node (gnat_entity)))));
+ (Parent (Corresponding_Body
+ (Parent (Declaration_Node (gnat_entity)))));
return;
}
- /* 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. */
+ /* Check for old definition after the above call. This Freeze_Node
+ might be for one its Itypes. */
gnu_old
- = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
+ = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
- /* 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 = NULL_TREE;
+ 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;
/* 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 because of 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 a previous compilation of a spec for inlining
+ purposes. */
if (gnu_old
&& ((TREE_CODE (gnu_old) == FUNCTION_DECL
- && (kind == E_Function || kind == E_Procedure))
- || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
- && kind == E_Subprogram_Type)))
+ && (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)))
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 its own
+ however, because each might legitimately be elaborated before it's 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 (kind, Incomplete_Or_Private_Kind)
+ gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity))
&& No (Freeze_Node (Full_View (gnat_entity))))
|| Is_Concurrent_Type (gnat_entity)
- || (IN (kind, Record_Kind)
+ || (IN (Ekind (gnat_entity), 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 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 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 (gnu_old)
{
save_gnu_tree (gnat_entity, NULL_TREE, false);
- 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)
+ 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)
save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
}
- if (IN (kind, Incomplete_Or_Private_Kind)
+ if (IN (Ekind (gnat_entity), 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);
+ 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);
}
else
- {
- 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);
+ gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
/* If we've made any pointers to the old version of this type, we
have to update them. */
{
gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
- operand = gnat_protect_expr (operand);
+ operand = protect_multiple_eval (operand);
return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
operand, TYPE_MIN_VALUE (gnu_type)),
build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
tree right, Node_Id gnat_node)
{
- tree lhs = gnat_protect_expr (left);
- tree rhs = gnat_protect_expr (right);
+ tree lhs = protect_multiple_eval (left);
+ tree rhs = protect_multiple_eval (right);
tree type_max = TYPE_MAX_VALUE (gnu_type);
tree type_min = TYPE_MIN_VALUE (gnu_type);
tree gnu_expr;
return gnu_expr;
/* Checked expressions must be evaluated only once. */
- gnu_expr = gnat_protect_expr (gnu_expr);
+ gnu_expr = protect_multiple_eval (gnu_expr);
/* There's no good type to use here, so we might as well use
integer_type_node. Note that the form of the check is
tree gnu_expr_check;
/* Checked expressions must be evaluated only once. */
- gnu_expr = gnat_protect_expr (gnu_expr);
+ gnu_expr = protect_multiple_eval (gnu_expr);
/* Must do this computation in the base type in case the expression's
type is an unsigned subtypes. */
&& !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
{
/* Ensure GNU_EXPR only gets evaluated once. */
- tree gnu_input = gnat_protect_expr (gnu_result);
+ tree gnu_input = protect_multiple_eval (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);
conversion of the input to the calc_type (if necessary). */
gnu_zero = convert (gnu_in_basetype, integer_zero_node);
- gnu_result = gnat_protect_expr (gnu_result);
+ gnu_result = protect_multiple_eval (gnu_result);
gnu_conv = convert (calc_type, gnu_result);
gnu_comp
= fold_build2 (GE_EXPR, integer_type_node, gnu_result, gnu_zero);
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. */