OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2004-07-13  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* decl.c: (gnat_to_gnu_entity, object case): Convert initializer to
	object type.
	(gnat_to_gnu_entity, case E_Record_Subtype): Properly set
	TYPE_STUB_DECL.

	* misc.c (gnat_types_compatible_p): New function.
	(LANG_HOOKS_TYPES_COMPATIBLE_P): New hook, to use it.
	(LANG_HOOKS_TYPE_MAX_SIZE, gnat_type_max_size): New.

	* trans.c (gigi): Move processing of main N_Compilation_Unit here.
	(gnat_to_gnu, case N_Compilation_Unit): Just handle nested case here.
	(add_stmt): Force walking of sizes and DECL_INITIAL for DECL_EXPR.
	(mark_visited): Don't mark dummy type.
	(tree_transform <N_Procedure_Call_Statement>): Unless this is an In
	parameter, we must remove any LJM building from GNU_NAME.
	(gnat_to_gnu, case N_String_Literal): Fill in indices in CONSTRUCTOR.
	(pos_to_constructor): Use int_const_binop.
	(gnat_to_gnu, case N_Identifier): Don't reference DECL_INITIAL of
	PARM_DECL.

	* utils.c (gnat_init_decl_processing): Don't make two "void" decls.
	(gnat_pushlevel): Set TREE_USE on BLOCK node.
	(gnat_install_builtins): Add __builtin_memset.

2004-07-13  Olivier Hainque  <hainque@act-europe.fr>

	* decl.c (gnat_to_gnu_entity <E_Variable>): If we are making a pointer
	for a renaming, stabilize the initialization expression if we are at a
	local level.  At the local level, uses of the renaming may be performed
	by a direct dereference of the initializing expression, and we don't
	want possible variables there to be evaluated for every use.

	* trans.c (gnat_stabilize_reference, gnat_stabilize_reference_1):
	Propagate TREE_SIDE_EFFECTS and TREE_THIS_VOLATILE to avoid loosing
	them on the way.  Account for the fact that we may introduce side
	effects in the process.

From-SVN: r84647
This commit is contained in:
Arnaud Charlet 2004-07-13 23:40:51 +02:00
parent 1ff3c0761f
commit a5cb3b3025
5 changed files with 300 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/ada/ChangeLog
View File

@ -1,3 +1,42 @@
2004-07-13 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c: (gnat_to_gnu_entity, object case): Convert initializer to
object type.
(gnat_to_gnu_entity, case E_Record_Subtype): Properly set
TYPE_STUB_DECL.
* misc.c (gnat_types_compatible_p): New function.
(LANG_HOOKS_TYPES_COMPATIBLE_P): New hook, to use it.
(LANG_HOOKS_TYPE_MAX_SIZE, gnat_type_max_size): New.
* trans.c (gigi): Move processing of main N_Compilation_Unit here.
(gnat_to_gnu, case N_Compilation_Unit): Just handle nested case here.
(add_stmt): Force walking of sizes and DECL_INITIAL for DECL_EXPR.
(mark_visited): Don't mark dummy type.
(tree_transform <N_Procedure_Call_Statement>): Unless this is an In
parameter, we must remove any LJM building from GNU_NAME.
(gnat_to_gnu, case N_String_Literal): Fill in indices in CONSTRUCTOR.
(pos_to_constructor): Use int_const_binop.
(gnat_to_gnu, case N_Identifier): Don't reference DECL_INITIAL of
PARM_DECL.
* utils.c (gnat_init_decl_processing): Don't make two "void" decls.
(gnat_pushlevel): Set TREE_USE on BLOCK node.
(gnat_install_builtins): Add __builtin_memset.
2004-07-13 Olivier Hainque <hainque@act-europe.fr>
* decl.c (gnat_to_gnu_entity <E_Variable>): If we are making a pointer
for a renaming, stabilize the initialization expression if we are at a
local level. At the local level, uses of the renaming may be performed
by a direct dereference of the initializing expression, and we don't
want possible variables there to be evaluated for every use.
* trans.c (gnat_stabilize_reference, gnat_stabilize_reference_1):
Propagate TREE_SIDE_EFFECTS and TREE_THIS_VOLATILE to avoid loosing
them on the way. Account for the fact that we may introduce side
effects in the process.
2004-07-13 Richard Henderson <rth@redhat.com>
* misc.c (default_pass_by_ref): Use pass_by_reference.

60
gcc/ada/decl.c
View File

@ -728,15 +728,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
(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. */
@ -761,8 +762,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& !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)
@ -775,12 +777,33 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
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;
}
@ -999,17 +1022,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
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

38
gcc/ada/misc.c
View File

@ -94,6 +94,7 @@ static bool gnat_post_options (const char **);
static HOST_WIDE_INT gnat_get_alias_set (tree);
static void gnat_print_decl (FILE *, tree, int);
static void gnat_print_type (FILE *, tree, int);
static int gnat_types_compatible_p (tree, tree);
static const char *gnat_printable_name (tree, int);
static tree gnat_eh_runtime_type (tree);
static int gnat_eh_type_covers (tree, tree);
@ -102,6 +103,7 @@ static rtx gnat_expand_expr (tree, rtx, enum machine_mode, int,
rtx *);
static void internal_error_function (const char *, va_list *);
static void gnat_adjust_rli (record_layout_info);
static tree gnat_type_max_size (tree);
/* Definitions for our language-specific hooks. */
@ -141,6 +143,10 @@ static void gnat_adjust_rli (record_layout_info);
#define LANG_HOOKS_PRINT_DECL gnat_print_decl
#undef LANG_HOOKS_PRINT_TYPE
#define LANG_HOOKS_PRINT_TYPE gnat_print_type
#undef LANG_HOOKS_TYPES_COMPATIBLE_P
#define LANG_HOOKS_TYPES_COMPATIBLE_P gnat_types_compatible_p
#undef LANG_HOOKS_TYPE_MAX_SIZE
#define LANG_HOOKS_TYPE_MAX_SIZE gnat_type_max_size
#undef LANG_HOOKS_DECL_PRINTABLE_NAME
#define LANG_HOOKS_DECL_PRINTABLE_NAME gnat_printable_name
#undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
@ -555,6 +561,27 @@ gnat_print_type (FILE *file, tree node, int indent)
}
}
/* We consider two types compatible if they have the same main variant,
but we also consider two array types compatible if they have the same
component type and bounds.
??? We may also want to generalize to considering lots of integer types
compatible, but we need to understand the effects of alias sets first. */
static int
gnat_types_compatible_p (tree x, tree y)
{
if (TREE_CODE (x) == ARRAY_TYPE && TREE_CODE (y) == ARRAY_TYPE
&& gnat_types_compatible_p (TREE_TYPE (x), TREE_TYPE (y))
&& operand_equal_p (TYPE_MIN_VALUE (TYPE_DOMAIN (x)),
TYPE_MIN_VALUE (TYPE_DOMAIN (y)), 0)
&& operand_equal_p (TYPE_MAX_VALUE (TYPE_DOMAIN (x)),
TYPE_MAX_VALUE (TYPE_DOMAIN (y)), 0))
return 1;
else
return TYPE_MAIN_VARIANT (x) == TYPE_MAIN_VARIANT (y);
}
static const char *
gnat_printable_name (tree decl, int verbosity)
{
@ -691,6 +718,15 @@ gnat_get_alias_set (tree type)
return -1;
}
/* GNU_TYPE is a type. Return its maxium size in bytes, if known. */
static tree
gnat_type_max_size (gnu_type)
tree gnu_type;
{
return max_size (TYPE_SIZE_UNIT (gnu_type), 1);
}
/* GNU_TYPE is a type. Determine if it should be passed by reference by
default. */
@ -709,7 +745,7 @@ default_pass_by_ref (tree gnu_type)
if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
return true;
if (AGGREGATE_TYPE_P (gnu_type)
&& (! host_integerp (TYPE_SIZE (gnu_type), 1)
|| 0 < compare_tree_int (TYPE_SIZE (gnu_type),

257
gcc/ada/trans.c
View File

@ -170,6 +170,8 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
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;
@ -198,9 +200,6 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
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. */
@ -228,7 +227,74 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
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 ());
}
/* 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);
}
/* Perform initializations for this module. */
@ -424,23 +490,38 @@ gnat_to_gnu (Node_Id gnat_node)
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,
@ -629,16 +710,22 @@ gnat_to_gnu (Node_Id gnat_node)
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));
}
@ -2149,7 +2236,7 @@ gnat_to_gnu (Node_Id gnat_node)
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)));
@ -2785,6 +2872,16 @@ gnat_to_gnu (Node_Id gnat_node)
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))
@ -3149,29 +3246,9 @@ gnat_to_gnu (Node_Id gnat_node)
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
@ -3180,20 +3257,6 @@ gnat_to_gnu (Node_Id gnat_node)
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)));
@ -3201,20 +3264,9 @@ gnat_to_gnu (Node_Id 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:
@ -3317,7 +3369,7 @@ gnat_to_gnu (Node_Id gnat_node)
(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);
@ -3358,7 +3410,7 @@ gnat_to_gnu (Node_Id gnat_node)
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. */
@ -3791,7 +3843,7 @@ gnat_to_gnu (Node_Id gnat_node)
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;
@ -4047,9 +4099,25 @@ add_stmt (tree gnu_stmt)
append_to_statement_list (gnu_stmt, &current_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. */
@ -4116,7 +4184,7 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
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));
@ -4134,7 +4202,10 @@ mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
{
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;
@ -4421,7 +4492,7 @@ gnat_expand_body_1 (tree gnu_decl, bool nested_p)
{
if (nested_p)
push_function_context ();
tree_rest_of_compilation (gnu_decl, nested_p);
if (nested_p)
@ -5304,9 +5375,7 @@ pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
= 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));
@ -5500,6 +5569,19 @@ gnat_stabilize_reference (tree ref, int force)
}
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;
}
@ -5569,6 +5651,9 @@ gnat_stabilize_reference_1 (tree e, int force)
}
TREE_READONLY (result) = TREE_READONLY (e);
TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
return result;
}

32
gcc/ada/utils.c
View File

@ -230,6 +230,7 @@ gnat_pushlevel ()
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. */
@ -362,7 +363,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
&& 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);
}
@ -404,9 +405,6 @@ gnat_init_decl_processing (void)
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);
@ -464,6 +462,13 @@ gnat_install_builtins ()
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);
@ -2827,10 +2832,8 @@ convert (tree type, tree expr)
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)
@ -2843,21 +2846,6 @@ convert (tree type, tree expr)
}
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. */