(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
- /* See if this is a renaming. If this is a constant renaming,
- treat it as a normal variable whose initial value is what
- is being renamed. We cannot do this if the type is
- unconstrained or class-wide.
+ /* See if this is a renaming. If this is a constant renaming, treat
+ it as a normal variable whose initial value is what is being
+ renamed. We cannot do this if the type is unconstrained or
+ class-wide.
Otherwise, if what we are renaming is a reference, we can simply
- return a stabilized version of that reference, after forcing
- any SAVE_EXPRs to be evaluated. But, if this is at global level,
- we can only do this if we know no SAVE_EXPRs will be made.
+ return a stabilized version of that reference, after forcing any
+ SAVE_EXPRs to be evaluated. But, if this is at global level, we
+ can only do this if we know no SAVE_EXPRs will be made.
+
Otherwise, make this into a constant pointer to the object we are
to rename. */
&& !Is_Array_Type (Etype (gnat_entity)))
;
- /* If this is a declaration or reference, we can just use that
- declaration or reference as this entity. */
+ /* If this is a declaration or reference that we can stabilize,
+ just use that declaration or reference as this entity unless
+ the latter has to be materialized. */
else if ((DECL_P (gnu_expr)
|| TREE_CODE_CLASS (TREE_CODE (gnu_expr)) == 'r')
&& ! Materialize_Entity (gnat_entity)
saved = 1;
break;
}
+ /* Otherwise, make this into a constant pointer to the object we
+ are to rename.
+
+ Stabilize it if we are not at the global level since in this
+ case the renaming evaluation may directly dereference the
+ initial value we make here instead of the pointer we will
+ assign it to. We don't want variables in the expression to be
+ evaluated every time the renaming is used, since the value of
+ these variables may change in between.
+
+ If we are at the global level and the value is not constant,
+ create_var_decl generates a mere elaboration assignment and
+ does not attach the initial expression to the declaration.
+ There is no possible direct initial-value dereference then. */
else
{
inner_const_flag = TREE_READONLY (gnu_expr);
const_flag = 1;
gnu_type = build_reference_type (gnu_type);
gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
+
+ if (! global_bindings_p ())
+ {
+ gnu_expr = gnat_stabilize_reference (gnu_expr, 1);
+ add_stmt (gnu_expr);
+ }
+
gnu_size = 0;
used_by_ref = 1;
}
with the symbol we need to export in addition. Don't use the
Interface_Name if there is an address clause (see CD30005). */
if (! Is_VMS_Exception (gnat_entity)
- &&
- ((Present (Interface_Name (gnat_entity))
- && No (Address_Clause (gnat_entity)))
- ||
- (Is_Public (gnat_entity)
- && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))))
+ && ((Present (Interface_Name (gnat_entity))
+ && No (Address_Clause (gnat_entity)))
+ || (Is_Public (gnat_entity)
+ && (! Is_Imported (gnat_entity)
+ || Is_Exported (gnat_entity)))))
gnu_ext_name = create_concat_name (gnat_entity, 0);
if (const_flag)
- gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
- | TYPE_QUAL_CONST));
+ {
+ gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
+ | TYPE_QUAL_CONST));
+ if (gnu_expr)
+ gnu_expr = convert (gnu_type, gnu_expr);
+ }
/* If this is constant initialized to a static constant and the
object has an aggregrate type, force it to be statically
Entity_Id standard_long_long_float, Entity_Id standard_exception_type,
Int gigi_operating_mode)
{
+ bool body_p;
+ Entity_Id gnat_unit_entity;
tree gnu_standard_long_long_float;
tree gnu_standard_exception_type;
TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
}
- if (Nkind (gnat_root) != N_Compilation_Unit)
- gigi_abort (301);
-
/* Save the type we made for integer as the type for Standard.Integer.
Then make the rest of the standard types. Note that some of these
may be subtypes. */
if (Exception_Mechanism == GCC_ZCX)
gnat_init_gcc_eh ();
- gnat_to_gnu (gnat_root);
+ /* Make the decl for the elaboration procedure. */
+ body_p = (Defining_Entity (Unit (gnat_root)),
+ Nkind (Unit (gnat_root)) == N_Package_Body
+ || Nkind (Unit (gnat_root)) == N_Subprogram_Body);
+ gnat_unit_entity = Defining_Entity (Unit (gnat_root));
+
+ gnu_elab_proc_decl
+ = create_subprog_decl
+ (create_concat_name (gnat_unit_entity,
+ body_p ? "elabb" : "elabs"),
+ NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0, 0, gnat_unit_entity);
+
+ DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
+ allocate_struct_function (gnu_elab_proc_decl);
+ Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
+ cfun = 0;
+
+ /* For a body, first process the spec if there is one. */
+ if (Nkind (Unit (gnat_root)) == N_Package_Body
+ || (Nkind (Unit (gnat_root)) == N_Subprogram_Body
+ && ! Acts_As_Spec (gnat_root)))
+ add_stmt (gnat_to_gnu (Library_Unit (gnat_root)));
+
+ process_inlined_subprograms (gnat_root);
+
+ if (type_annotate_only)
+ {
+ elaborate_all_entities (gnat_root);
+
+ if (Nkind (Unit (gnat_root)) == N_Subprogram_Declaration
+ || Nkind (Unit (gnat_root)) == N_Generic_Package_Declaration
+ || Nkind (Unit (gnat_root)) == N_Generic_Subprogram_Declaration)
+ return;
+ }
+
+ process_decls (Declarations (Aux_Decls_Node (gnat_root)), Empty, Empty,
+ 1, 1);
+ add_stmt (gnat_to_gnu (Unit (gnat_root)));
+
+ /* Process any pragmas and actions following the unit. */
+ add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_root)));
+ add_stmt_list (Actions (Aux_Decls_Node (gnat_root)));
+
+ /* Generate elaboration code for this unit, if necessary, and say whether
+ we did or not. */
+ Set_Has_No_Elaboration_Code (gnat_root, build_unit_elab ());
+}
+\f
+/* Perform initializations for this module. */
+
+void
+gnat_init_stmt_group ()
+{
+ /* Initialize ourselves. */
+ init_code_table ();
+ start_stmt_group ();
+
+ global_stmt_group = current_stmt_group;
+
+ /* Enable GNAT stack checking method if needed */
+ if (!Stack_Check_Probes_On_Target)
+ set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
+
+ if (Exception_Mechanism == Front_End_ZCX)
+ abort ();
+
+ REAL_ARITHMETIC (dconstp5, RDIV_EXPR, dconst1, dconst2);
+ REAL_ARITHMETIC (dconstmp5, RDIV_EXPR, dconstm1, dconst2);
}
\f
/* Perform initializations for this module. */
if (TREE_CODE (gnu_result) == PARM_DECL
&& DECL_BY_COMPONENT_PTR_P (gnu_result))
- gnu_result = convert (build_pointer_type (gnu_result_type),
- gnu_result);
+ gnu_result
+ = build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (build_pointer_type (gnu_result_type),
+ gnu_result));
/* If the object is constant, we try to do the dereference directly
through the DECL_INITIAL. This is actually required in order to
get correct aliasing information for renamed objects that are
- components of non-aliased aggregates, because the type of
- the renamed object and that of the aggregate don't alias. */
- if (TREE_READONLY (gnu_result)
- && DECL_INITIAL (gnu_result)
- /* Strip possible conversion to reference type. */
- && (initial = TREE_CODE (DECL_INITIAL (gnu_result)) == NOP_EXPR
- ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0)
- : DECL_INITIAL (gnu_result), 1)
- && TREE_CODE (initial) == ADDR_EXPR
- && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF
- || TREE_CODE (TREE_OPERAND (initial, 0)) == COMPONENT_REF))
+ components of non-aliased aggregates, because the type of the
+ renamed object and that of the aggregate don't alias.
+
+ Note that we expect the initial value to have been stabilized.
+ If it contains e.g. a variable reference, we certainly don't want
+ to re-evaluate the variable each time the renaming is used.
+
+ Stabilization is currently not performed at the global level but
+ create_var_decl avoids setting DECL_INITIAL if the value is not
+ constant then, and we get to the pointer dereference below.
+
+ ??? Couldn't the aliasing issue show up again in this case ?
+ There is no obvious reason why not. */
+ else if (TREE_READONLY (gnu_result)
+ && DECL_INITIAL (gnu_result)
+ /* Strip possible conversion to reference type. */
+ && ((initial = TREE_CODE (DECL_INITIAL (gnu_result))
+ == NOP_EXPR
+ ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0)
+ : DECL_INITIAL (gnu_result), 1))
+ && TREE_CODE (initial) == ADDR_EXPR
+ && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF
+ || (TREE_CODE (TREE_OPERAND (initial, 0))
+ == COMPONENT_REF)))
gnu_result = TREE_OPERAND (initial, 0);
else
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
int length = String_Length (gnat_string);
int i;
tree gnu_list = NULL_TREE;
+ tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
for (i = 0; i < length; i++)
- gnu_list
- = tree_cons (NULL_TREE,
- convert (TREE_TYPE (gnu_result_type),
- build_int_2 (Get_String_Char (gnat_string,
- i + 1),
- 0)),
+ {
+ gnu_list
+ = tree_cons (gnu_idx,
+ convert (TREE_TYPE (gnu_result_type),
+ build_int_2
+ (Get_String_Char (gnat_string, i + 1),
+ 0)),
gnu_list);
+ gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
+ 0);
+ }
+
gnu_result
= gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
}
TREE_VALUE (gnu_switch_label_stack)));
}
-
+
/* Now emit a definition of the label all the cases branched to. */
add_stmt (build1 (LABEL_EXPR, void_type_node,
TREE_VALUE (gnu_switch_label_stack)));
gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
gnu_actual);
+ /* Unless this is an In parameter, we must remove any LJM building
+ from GNU_NAME. */
+ if (Ekind (gnat_formal) != E_In_Parameter
+ && TREE_CODE (gnu_name) == CONSTRUCTOR
+ && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
+ && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
+ gnu_name
+ = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
+ gnu_name);
+
if (Ekind (gnat_formal) != E_Out_Parameter
&& ! unchecked_convert_p
&& Do_Range_Check (gnat_actual))
case N_Compilation_Unit:
- /* If this is the main unit, make the decl for the elaboration
- procedure. Otherwise, push a statement group for this nested
- compilation unit. */
- if (gnat_node == Cunit (Main_Unit))
- {
- 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));
-
- gnu_elab_proc_decl
- = create_subprog_decl
- (create_concat_name (gnat_unit_entity,
- body_p ? "elabb" : "elabs"),
- NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0, 0, gnat_unit_entity);
-
- DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
- allocate_struct_function (gnu_elab_proc_decl);
- Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
- cfun = 0;
- }
- else
- start_stmt_group ();
+ /* This is not called for the main unit, which is handled in function
+ gigi above. */
+ start_stmt_group ();
/* For a body, first process the spec if there is one. */
if (Nkind (Unit (gnat_node)) == N_Package_Body
add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
process_inlined_subprograms (gnat_node);
-
- if (type_annotate_only && gnat_node == Cunit (Main_Unit))
- {
- elaborate_all_entities (gnat_node);
-
- if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
- || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
- || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
- {
- gnu_result = alloc_stmt_list ();
- break;
- }
- }
-
process_decls (Declarations (Aux_Decls_Node (gnat_node)),
Empty, Empty, 1, 1);
add_stmt (gnat_to_gnu (Unit (gnat_node)));
/* Process any pragmas and actions following the unit. */
add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
-
- /* If this is the main unit, generate elaboration code for this
- unit, if necessary, and say whether we did or not. Otherwise,
- there is no elaboration code and we end our statement group. */
- if (gnat_node == Cunit (Main_Unit))
- {
- Set_Has_No_Elaboration_Code (gnat_node, build_unit_elab ());
- gnu_result = alloc_stmt_list ();
- }
- else
- {
- Set_Has_No_Elaboration_Code (gnat_node, 1);
- gnu_result = end_stmt_group ();
- }
+
+ Set_Has_No_Elaboration_Code (gnat_node, 1);
+ gnu_result = end_stmt_group ();
break;
case N_Subprogram_Body_Stub:
(set_jmpbuf_decl,
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_jmpbuf_decl)));
-
+
if (Present (First_Real_Statement (gnat_node)))
process_decls (Statements (gnat_node), Empty,
First_Real_Statement (gnat_node), 1, 1);
gnat_temp = Next_Non_Pragma (gnat_temp))
{
gnu_expr = gnat_to_gnu (gnat_temp);
-
+
/* If this is the first one, set it as the outer one.
Otherwise, point the "else" part of the previous handler
to us. Then point to our "else" part. */
gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node),
+ Storage_Pool (gnat_node),
gnat_node);
}
break;
append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list);
/* If we're at top level, show everything in here is in use in case
- any of it is shared by a subprogram. */
+ any of it is shared by a subprogram.
+
+ ??? If this is a DECL_EXPR for a VAR_DECL or CONST_DECL, we must
+ walk the sizes and DECL_INITIAL since we won't be walking the
+ BIND_EXPR here. This whole thing is a mess! */
if (!current_function_decl)
- walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
+ {
+ walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
+ if (TREE_CODE (gnu_stmt) == DECL_EXPR
+ && (TREE_CODE (DECL_EXPR_DECL (gnu_stmt)) == VAR_DECL
+ || TREE_CODE (DECL_EXPR_DECL (gnu_stmt)) == CONST_DECL))
+ {
+ tree gnu_decl = DECL_EXPR_DECL (gnu_stmt);
+
+ walk_tree (&DECL_SIZE (gnu_decl), mark_visited, NULL, NULL);
+ walk_tree (&DECL_SIZE_UNIT (gnu_decl), mark_visited, NULL, NULL);
+ walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL);
+ }
+ }
}
/* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
tree gnu_assign_stmt
= build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_lhs, DECL_INITIAL (gnu_decl));
-
+
DECL_INITIAL (gnu_decl) = 0;
annotate_with_locus (gnu_assign_stmt,
DECL_SOURCE_LOCATION (gnu_decl));
{
if (TREE_VISITED (*tp))
*walk_subtrees = 0;
- else
+
+ /* Don't mark a dummy type as visited because we want to mark its sizes
+ and fields once it's filled in. */
+ else if (!TYPE_IS_DUMMY_P (*tp))
TREE_VISITED (*tp) = 1;
return NULL_TREE;
{
if (nested_p)
push_function_context ();
-
+
tree_rest_of_compilation (gnu_decl, nested_p);
if (nested_p)
= tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr),
gnu_expr_list);
- gnu_index = fold (build2 (PLUS_EXPR, TREE_TYPE (gnu_index), gnu_index,
- convert (TREE_TYPE (gnu_index),
- integer_one_node)));
+ gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
}
return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
}
TREE_READONLY (result) = TREE_READONLY (ref);
+
+ /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
+ expression may not be sustained across some paths, such as the way via
+ build1 for INDIRECT_REF. We re-populate those flags here for the general
+ case, which is consistent with the GCC version of this routine.
+
+ Special care should be taken regarding TREE_SIDE_EFFECTS, because some
+ paths introduce side effects where there was none initially (e.g. calls
+ to save_expr), and we also want to keep track of that. */
+
+ TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
+ TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
+
return result;
}
}
TREE_READONLY (result) = TREE_READONLY (e);
+
+ TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
+ TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
return result;
}
\f
BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
BLOCK_VARS (newlevel->block) = BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
+ TREE_USED (newlevel->block) = 1;
/* Add this level to the front of the chain (stack) of levels that are
active. */
&& DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl)))
&& ! DECL_ARTIFICIAL (decl))))
TYPE_NAME (TREE_TYPE (decl)) = decl;
-
+
if (TREE_CODE (decl) != CONST_DECL)
rest_of_decl_compilation (decl, NULL, global_bindings_p (), 0);
}
gnat_pushdecl (build_decl (TYPE_DECL, get_identifier ("long integer"),
long_integer_type_node),
Empty);
- gnat_pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
- void_type_node),
- Empty);
ptr_void_type_node = build_pointer_type (void_type_node);
gnat_define_builtin ("__builtin_memcmp", ftype, BUILT_IN_MEMCMP,
"memcmp", false);
+ tmp = tree_cons (NULL_TREE, size_type_node, void_list_node);
+ tmp = tree_cons (NULL_TREE, integer_type_node, tmp);
+ tmp = tree_cons (NULL_TREE, ptr_void_type_node, tmp);
+ ftype = build_function_type (integer_type_node, tmp);
+ gnat_define_builtin ("__builtin_memset", ftype, BUILT_IN_MEMSET,
+ "memset", false);
+
tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
ftype = build_function_type (integer_type_node, tmp);
gnat_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, "clz", true);
return expr;
case STRING_CST:
- case CONSTRUCTOR:
/* If we are converting a STRING_CST to another constrained array type,
- just make a new one in the proper type. Likewise for
- CONSTRUCTOR if the alias sets are the same. */
+ just make a new one in the proper type. */
if (code == ecode && AGGREGATE_TYPE_P (etype)
&& ! (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
&& TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
}
break;
- case COMPONENT_REF:
- /* If we are converting between two aggregate types of the same
- kind, size, mode, and alignment, just make a new COMPONENT_REF.
- This avoid unneeded conversions which makes reference computations
- more complex. */
- if (code == ecode && TYPE_MODE (type) == TYPE_MODE (etype)
- && AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
- && TYPE_ALIGN (type) == TYPE_ALIGN (etype)
- && operand_equal_p (TYPE_SIZE (type), TYPE_SIZE (etype), 0)
- && get_alias_set (type) == get_alias_set (etype))
- return build (COMPONENT_REF, type, TREE_OPERAND (expr, 0),
- TREE_OPERAND (expr, 1), NULL_TREE);
-
- break;
-
case UNCONSTRAINED_ARRAY_REF:
/* Convert this to the type of the inner array by getting the address of
the array from the template. */
projects / gcc.git / commitdiff