Skip to content

R
riscv-gcc-1
Commit 909f21b3 by Richard Kenner Committed by Richard Kenner
Options

decl.c: Remove calls to add_decl_expr... 

	* decl.c: Remove calls to add_decl_expr, pushdecl, rest_of_compilation,
	and rest_of_type_compilation; add arg to create_*_decl.
 	(annotate_decl_with_node): Deleted.
	(gnat_to_gnu_entity, case E_Array_Type): Set location of fields.
	* gigi.h (get_decls, block_has_vars, pushdecl): Deleted.
	(get_current_block_context, gnat_pushdecl): New declarations.
	(gnat_init_stmt_group): Likewise.
	(create_var_decl, create_type_decl, create_subprog_decl): Add new arg.
	* misc.c (LANG_HOOKS_CLEAR_BINDING_STACK): Deleted.
	(LANG_HOOKS_GETDECLS, LANG_HOOKS_PUSHDECL): Deleted.
	(gnat_init): Call gnat_init_stmt_group.
	* trans.c (global_stmt_group, gnu_elab_proc_decl): New variables.
	(gnu_pending_elaboration_list): Deleted.
	(mark_visited, mark_unvisited, gnat_init_stmt_group): New functions.
	(gigi): Rearrange initialization calls and move some to last above.
	(gnat_to_gnu): If statement and not in procedure, go into elab proc.
	Delete calls to add_decl_expr; add arg to create_*_decl.
	(gnat_to_gnu, case N_Loop): Recalculate side effects on COND_EXPR.
	(gnat_to_gnu, case N_Subprogram_Body): Move some code to
	begin_subprog_body and call it.
	Don't push and pop ggc context.
	(gnat_to_gnu, case N_Compilation_Unit): Rework to support elab proc.
	(add_stmt): Remove handling of DECL_EXPR from here.
	If not in function, mark visited.
	(add_decl_expr): Put global at top level.
	Check for cases of DECL_INITIAL we have to handle here.
	(process_type): Add extra arg to create_type_decl.
	(build_unit_elab): Rework to just gimplify.
	* utils.c (pending_elaborations, elist_stack, getdecls): Deleted.
	(block_has_vars, mark_visited, add_pending_elaborations): Likewise.
	(get_pending_elaborations, pending_elaborations_p): Likewise.
	(push_pending_elaborations, pop_pending_elaborations): Likewise.
	(get_elaboration_location, insert_elaboration_list): Likewise.
	(gnat_binding_level): Renamed from ada_binding_level.
	(init_gnat_to_gnu): Don't clear pending_elaborations.
	(global_bindings_p): Treat as global if no current_binding_level.
	(set_current_block_context): New function.
	(gnat_pushdecl): Renamed from pushdecl; major rework.
	All callers changed.
	(create_type_decl, create_var_decl, create_subprog_decl): Add new arg.
	(finish_record_type): Call call pushdecl for stub decl.
	(function_nesting_depth): Deleted.
	(begin_subprog_body): Delete obsolete code.
	* utils2.c (build_call_alloc_dealloc): Add new arg to create_var_decl.

From-SVN: r83816
parent 0b55e932
Showing with 511 additions and 626 deletions
gcc/ada/ChangeLog
2004-06-28 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c: Remove calls to add_decl_expr, pushdecl, rest_of_compilation,
and rest_of_type_compilation; add arg to create_*_decl.
(annotate_decl_with_node): Deleted.
(gnat_to_gnu_entity, case E_Array_Type): Set location of fields.
* gigi.h (get_decls, block_has_vars, pushdecl): Deleted.
(get_current_block_context, gnat_pushdecl): New declarations.
(gnat_init_stmt_group): Likewise.
(create_var_decl, create_type_decl, create_subprog_decl): Add new arg.
* misc.c (LANG_HOOKS_CLEAR_BINDING_STACK): Deleted.
(LANG_HOOKS_GETDECLS, LANG_HOOKS_PUSHDECL): Deleted.
(gnat_init): Call gnat_init_stmt_group.
* trans.c (global_stmt_group, gnu_elab_proc_decl): New variables.
(gnu_pending_elaboration_list): Deleted.
(mark_visited, mark_unvisited, gnat_init_stmt_group): New functions.
(gigi): Rearrange initialization calls and move some to last above.
(gnat_to_gnu): If statement and not in procedure, go into elab proc.
Delete calls to add_decl_expr; add arg to create_*_decl.
(gnat_to_gnu, case N_Loop): Recalculate side effects on COND_EXPR.
(gnat_to_gnu, case N_Subprogram_Body): Move some code to
begin_subprog_body and call it.
Don't push and pop ggc context.
(gnat_to_gnu, case N_Compilation_Unit): Rework to support elab proc.
(add_stmt): Remove handling of DECL_EXPR from here.
If not in function, mark visited.
(add_decl_expr): Put global at top level.
Check for cases of DECL_INITIAL we have to handle here.
(process_type): Add extra arg to create_type_decl.
(build_unit_elab): Rework to just gimplify.
* utils.c (pending_elaborations, elist_stack, getdecls): Deleted.
(block_has_vars, mark_visited, add_pending_elaborations): Likewise.
(get_pending_elaborations, pending_elaborations_p): Likewise.
(push_pending_elaborations, pop_pending_elaborations): Likewise.
(get_elaboration_location, insert_elaboration_list): Likewise.
(gnat_binding_level): Renamed from ada_binding_level.
(init_gnat_to_gnu): Don't clear pending_elaborations.
(global_bindings_p): Treat as global if no current_binding_level.
(set_current_block_context): New function.
(gnat_pushdecl): Renamed from pushdecl; major rework.
All callers changed.
(create_type_decl, create_var_decl, create_subprog_decl): Add new arg.
(finish_record_type): Call call pushdecl for stub decl.
(function_nesting_depth): Deleted.
(begin_subprog_body): Delete obsolete code.
* utils2.c (build_call_alloc_dealloc): Add new arg to create_var_decl.
2004-06-28 Robert Dewar <dewar@gnat.com>
* mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
......
gcc/ada/decl.c
......@@ -103,7 +103,6 @@ static void set_rm_size (Uint, tree, Entity_Id);
static tree make_type_from_size (tree, tree, int);
static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
static void check_ok_for_atomic (tree, Entity_Id, int);
static void annotate_decl_with_node (tree, Node_Id);
/* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
GCC type corresponding to that entity. GNAT_ENTITY is assumed to
......@@ -957,9 +956,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_new_var
= create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
NULL_TREE, gnu_new_type, gnu_expr,
0, 0, 0, 0, 0);
annotate_decl_with_node (gnu_new_var, gnat_entity);
add_decl_expr (gnu_new_var, gnat_entity);
0, 0, 0, 0, 0, gnat_entity);
if (gnu_expr != 0)
add_stmt_with_node
......@@ -1028,8 +1025,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_expr, const_flag,
Is_Public (gnat_entity),
imported_p || !definition,
static_p, attr_list);
annotate_decl_with_node (gnu_decl, gnat_entity);
static_p, attr_list, gnat_entity);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
......@@ -1041,8 +1037,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (Present (Address_Clause (gnat_entity)) && used_by_ref)
DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
add_decl_expr (gnu_decl, gnat_entity);
if (definition && DECL_SIZE (gnu_decl) != 0
&& get_block_jmpbuf_decl ()
&& (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
......@@ -1069,9 +1063,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
tree gnu_corr_var
= create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, 0, Is_Public (gnat_entity), 0,
static_p, 0);
static_p, 0, gnat_entity);
add_decl_expr (gnu_corr_var, gnat_entity);
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
}
......@@ -1152,9 +1145,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_type);
tree gnu_literal
= create_var_decl (get_entity_name (gnat_literal),
0, gnu_type, gnu_value, 1, 0, 0, 0, 0);
0, gnu_type, gnu_value, 1, 0, 0, 0, 0,
gnat_literal);
add_decl_expr (gnu_literal, gnat_literal);
save_gnu_tree (gnat_literal, gnu_literal, 0);
gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
gnu_value, gnu_literal_list);
......@@ -1463,7 +1456,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
this_deferred = this_made_decl = 1;
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
debug_info_p, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, 0);
saved = 1;
}
......@@ -1526,8 +1519,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_ind_subtype,
gnu_template_type, 0, 0, 0, 0);
annotate_decl_with_node (gnu_min_field, gnat_entity);
annotate_decl_with_node (gnu_max_field, gnat_entity);
Sloc_to_locus (Sloc (gnat_entity),
&DECL_SOURCE_LOCATION (gnu_min_field));
Sloc_to_locus (Sloc (gnat_entity),
&DECL_SOURCE_LOCATION (gnu_max_field));
gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
/* We can't use build_component_ref here since the template
......@@ -1669,8 +1664,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
create_type_decl (create_concat_name (gnat_entity, "XUA"),
tem, 0, ! Comes_From_Source (gnat_entity),
debug_info_p);
rest_of_type_compilation (gnu_fat_type, global_bindings_p ());
debug_info_p, gnat_entity);
/* Create a record type for the object and its template and
set the template at a negative offset. */
......@@ -1688,7 +1682,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* Give the thin pointer type a name. */
create_type_decl (create_concat_name (gnat_entity, "XUX"),
build_pointer_type (tem), 0,
! Comes_From_Source (gnat_entity), debug_info_p);
! Comes_From_Source (gnat_entity), debug_info_p,
gnat_entity);
}
break;
......@@ -2060,8 +2055,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
* Treat_As_Volatile (gnat_entity))));
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
annotate_decl_with_node (gnu_decl, gnat_entity);
debug_info_p, gnat_entity);
if (! Comes_From_Source (gnat_entity))
DECL_ARTIFICIAL (gnu_decl) = 1;
......@@ -2291,8 +2285,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
this_deferred = 1;
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
annotate_decl_with_node (gnu_decl, gnat_entity);
debug_info_p, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, 0);
this_made_decl = saved = 1;
}
......@@ -2571,7 +2564,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = gnu_entity_id;
TYPE_STUB_DECL (gnu_type)
= pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type));
= create_type_decl (NULL_TREE, gnu_type, NULL, 0, 0,
gnat_entity);
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
for (gnat_field = First_Entity (gnat_entity);
......@@ -2736,11 +2730,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
TYPE_NAME (gnu_type) = gnu_entity_id;
TYPE_STUB_DECL (gnu_type)
= pushdecl (build_decl (TYPE_DECL, TYPE_NAME (gnu_type),
gnu_type));
DECL_ARTIFICIAL (TYPE_STUB_DECL (gnu_type)) = 1;
DECL_IGNORED_P (TYPE_STUB_DECL (gnu_type)) = ! debug_info_p;
rest_of_type_compilation (gnu_type, global_bindings_p ());
= create_type_decl (TYPE_NAME (gnu_type), gnu_type,
NULL, 1, debug_info_p, gnat_entity);
}
/* Otherwise, go down all the components in the new type and
......@@ -2772,7 +2763,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
(make_dummy_type (Directly_Designated_Type (gnat_entity)));
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
debug_info_p, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, 0);
this_made_decl = saved = 1;
......@@ -3039,7 +3030,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
debug_info_p, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, 0);
this_made_decl = saved = 1;
......@@ -3500,7 +3491,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
DECL_POINTS_TO_READONLY_P (gnu_param)
= (Ekind (gnat_param) == E_In_Parameter
&& (by_ref_p || by_component_ptr_p));
annotate_decl_with_node (gnu_param, gnat_param);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_param));
save_gnu_tree (gnat_param, gnu_param, 0);
gnu_param_list = chainon (gnu_param, gnu_param_list);
......@@ -3528,7 +3520,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
gnu_return_type, 0, 0, 0, 0);
annotate_decl_with_node (gnu_field, gnat_param);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_field));
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
gnu_return_list = tree_cons (gnu_field, gnu_param,
......@@ -3625,21 +3618,21 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_decl
= create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_address, 0, Is_Public (gnat_entity),
extern_flag, 0, 0);
extern_flag, 0, 0, gnat_entity);
DECL_BY_REF_P (gnu_decl) = 1;
add_decl_expr (gnu_decl, gnat_entity);
}
else if (kind == E_Subprogram_Type)
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
debug_info_p, gnat_entity);
else
{
gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
gnu_type, gnu_param_list,
inline_flag, public_flag,
extern_flag, attr_list);
extern_flag, attr_list,
gnat_entity);
DECL_STUBBED_P (gnu_decl)
= Convention (gnat_entity) == Convention_Stubbed;
}
......@@ -3700,8 +3693,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
updates when we see it. */
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
annotate_decl_with_node (gnu_decl, gnat_entity);
debug_info_p, gnat_entity);
save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
break;
......@@ -3916,16 +3908,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_USER_ALIGN (gnu_type) = 1;
if (gnu_decl == 0)
{
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
annotate_decl_with_node (gnu_decl, gnat_entity);
}
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
else
TREE_TYPE (gnu_decl) = gnu_type;
add_decl_expr (gnu_decl, gnat_entity);
}
if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
......@@ -4018,7 +4005,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_MAX_VALUE (gnu_scalar_type)
= gnat_to_gnu (Type_High_Bound (gnat_entity));
if (kind == E_Enumeration_Type)
if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
{
TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl;
......@@ -4301,11 +4288,10 @@ make_dummy_type (Entity_Id gnat_type)
gnu_type = make_node (ENUMERAL_TYPE);
TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
TYPE_DUMMY_P (gnu_type) = 1;
if (AGGREGATE_TYPE_P (gnu_type))
TYPE_STUB_DECL (gnu_type)
= pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type));
TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
TYPE_DUMMY_P (gnu_type) = 1;
dummy_node_table[gnat_underlying] = gnu_type;
return gnu_type;
......@@ -4538,15 +4524,12 @@ elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
/* Now create the variable if we need it. */
if (need_debug || (expr_variable && expr_global))
{
gnu_decl
= create_var_decl (create_concat_name (gnat_entity,
IDENTIFIER_POINTER (gnu_name)),
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1,
Is_Public (gnat_entity), ! definition, 0, 0);
annotate_decl_with_node (gnu_decl, gnat_entity);
add_decl_expr (gnu_decl, gnat_entity);
}
gnu_decl
= create_var_decl (create_concat_name (gnat_entity,
IDENTIFIER_POINTER (gnu_name)),
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1,
Is_Public (gnat_entity), ! definition, 0, 0,
gnat_entity);
/* We only need to use this variable if we are in global context since GCC
can do the right thing in the local case. */
......@@ -4757,7 +4740,8 @@ maybe_pad_type (tree type, tree size, unsigned int align,
0, ! Comes_From_Source (gnat_entity),
! (TYPE_NAME (type) != 0
&& TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
&& DECL_IGNORED_P (TYPE_NAME (type))));
&& DECL_IGNORED_P (TYPE_NAME (type))),
gnat_entity);
/* If we are changing the alignment and the input type is a record with
BLKmode and a small constant size, try to make a form that has an
......@@ -4805,7 +4789,9 @@ maybe_pad_type (tree type, tree size, unsigned int align,
|| ! DECL_IGNORED_P (TYPE_NAME (type))))
{
tree marker = make_node (RECORD_TYPE);
tree name = DECL_NAME (TYPE_NAME (record));
tree name = (TREE_CODE (TYPE_NAME (record)) == TYPE_DECL
? DECL_NAME (TYPE_NAME (record))
: TYPE_NAME (record));
tree orig_name = TYPE_NAME (type);
if (TREE_CODE (orig_name) == TYPE_DECL)
......@@ -4819,13 +4805,9 @@ maybe_pad_type (tree type, tree size, unsigned int align,
0, 0);
if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition)
{
tree gnu_xvz
= create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
sizetype, TYPE_SIZE (record), 0, 0, 0, 0, 0);
add_decl_expr (gnu_xvz, gnat_entity);
}
create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
sizetype, TYPE_SIZE (record), 0, 0, 0, 0, 0,
gnat_entity);
}
type = record;
......@@ -4965,9 +4947,7 @@ choices_to_gnu (tree operand, Node_Id choices)
DEFINITION is nonzero if this field is for a record being defined. */
static tree
gnat_to_gnu_field (Entity_Id gnat_field,
tree gnu_record_type,
int packed,
gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
int definition)
{
tree gnu_field_id = get_entity_name (gnat_field);
......@@ -5181,7 +5161,7 @@ gnat_to_gnu_field (Entity_Id gnat_field,
gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
packed, gnu_size, gnu_pos,
Is_Aliased (gnat_field));
annotate_decl_with_node (gnu_field, gnat_field);
Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
if (Ekind (gnat_field) == E_Discriminant)
......@@ -5250,14 +5230,9 @@ is_variable_size (tree type)
fields of the record and then the record type is finished. */
static void
components_to_record (tree gnu_record_type,
Node_Id component_list,
tree gnu_field_list,
int packed,
int definition,
tree *p_gnu_rep_list,
int cancel_alignment,
int all_rep)
components_to_record (tree gnu_record_type, Node_Id component_list,
tree gnu_field_list, int packed, int definition,
tree *p_gnu_rep_list, int cancel_alignment, int all_rep)
{
Node_Id component_decl;
Entity_Id gnat_field;
......@@ -6185,21 +6160,11 @@ check_ok_for_atomic (tree object, Entity_Id gnat_entity, int comp_p)
gnat_error_point, gnat_entity);
}
/* Set the DECL_SOURCE_LOCATION of GNU_DECL to the location of
GNAT_NODE. */
static void
annotate_decl_with_node (tree gnu_decl, Node_Id gnat_node)
{
Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_decl));
}
/* Given a type T, a FIELD_DECL F, and a replacement value R,
return a new type with all size expressions that contain F
updated by replacing F with R. This is identical to GCC's
substitute_in_type except that it knows about TYPE_INDEX_TYPE.
If F is NULL_TREE, always make a new RECORD_TYPE, even if nothing has
changed. */
/* Given a type T, a FIELD_DECL F, and a replacement value R, return a new type
with all size expressions that contain F updated by replacing F with R.
This is identical to GCC's substitute_in_type except that it knows about
TYPE_INDEX_TYPE. If F is NULL_TREE, always make a new RECORD_TYPE, even if
nothing has changed. */
tree
gnat_substitute_in_type (tree t, tree f, tree r)
......
gcc/ada/gigi.h
......@@ -111,8 +111,6 @@ extern tree get_unpadded_type (Entity_Id);
extern tree maybe_variable (tree);
/* Create a record type that contains a field of TYPE with a starting bit
position so that it is aligned to ALIGN bits. */
/* Create a record type that contains a field of TYPE with a starting bit
position so that it is aligned to ALIGN bits and is SIZE bytes long. */
extern tree make_aligning_type (tree, int, tree);
......@@ -367,14 +365,14 @@ extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
/* Returns non-zero if we are currently in the global binding level */
extern int global_bindings_p (void);
/* Returns the list of declarations in the current level. Note that this list
is in reverse order (it has to be so for back-end compatibility). */
extern tree getdecls (void);
/* Enter and exit a new binding level. */
extern void gnat_pushlevel (void);
extern void gnat_poplevel (void);
/* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
and point FNDECL to this BLOCK. */
extern void set_current_block_context (tree);
/* Set the jmpbuf_decl for the current binding level to DECL. */
extern void set_block_jmpbuf_decl (tree);
......@@ -386,15 +384,11 @@ extern tree get_block_jmpbuf_decl (void);
to handle the BLOCK node inside the BIND_EXPR. */
extern void insert_block (tree);
/* Return nonzero if the are any variables in the current block. */
extern int block_has_vars (void);
/* Records a ..._DECL node DECL as belonging to the current lexical scope
and uses GNAT_ENTITY for location information. */
extern void gnat_pushdecl (tree, Entity_Id);
/* Records a ..._DECL node DECL as belonging to the current lexical scope.
Returns the ..._DECL node. */
extern tree pushdecl (tree);
/* Create the predefined scalar types such as `integer_type_node' needed
in the gcc back-end and initialize the global binding level. */
extern void gnat_init_stmt_group (void);
extern void gnat_init_decl_processing (void);
extern void init_gigi_decls (tree, tree);
extern void gnat_init_gcc_eh (void);
......@@ -476,8 +470,9 @@ extern tree create_index_type (tree, tree, tree);
string) and TYPE is a ..._TYPE node giving its data type.
ARTIFICIAL_P is nonzero if this is a declaration that was generated
by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging
information about this type. */
extern tree create_type_decl (tree, tree, struct attrib *, int, int);
information about this type. GNAT_NODE is used for the position of
the decl. */
extern tree create_type_decl (tree, tree, struct attrib *, int, int, Node_Id);
/* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
ASM_NAME is its assembler name (if provided). TYPE is
......@@ -492,9 +487,11 @@ extern tree create_type_decl (tree, tree, struct attrib *, int, int);
when processing an external variable declaration (as opposed to a
definition: no storage is to be allocated for the variable here).
STATIC_FLAG is only relevant when not at top level. In that case
it indicates whether to always allocate storage to the variable. */
it indicates whether to always allocate storage to the variable.
GNAT_NODE is used for the position of the decl. */
extern tree create_var_decl (tree, tree, tree, tree, int, int, int, int,
struct attrib *);
struct attrib *, Node_Id);
/* Given a DECL and ATTR_LIST, apply the listed attributes. */
extern void process_attributes (tree, struct attrib *);
......@@ -542,10 +539,10 @@ extern tree create_param_decl (tree, tree, int);
node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
PARM_DECL nodes chained through the TREE_CHAIN field).
INLINE_FLAG, PUBLIC_FLAG, and EXTERN_FLAG are used to set the appropriate
fields in the FUNCTION_DECL. */
INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */
extern tree create_subprog_decl (tree, tree, tree, tree, int, int, int,
struct attrib *);
struct attrib *, Node_Id);
/* Returns a LABEL_DECL node for LABEL_NAME. */
extern tree create_label_decl (tree);
......
gcc/ada/misc.c
......@@ -123,12 +123,18 @@ static void gnat_adjust_rli (record_layout_info);
#define LANG_HOOKS_HONOR_READONLY true
#undef LANG_HOOKS_HASH_TYPES
#define LANG_HOOKS_HASH_TYPES false
#undef LANG_HOOKS_CLEAR_BINDING_STACK
#define LANG_HOOKS_CLEAR_BINDING_STACK lhd_do_nothing
#undef LANG_HOOKS_PUSHLEVEL
#define LANG_HOOKS_PUSHLEVEL lhd_do_nothing_i
#undef LANG_HOOKS_POPLEVEL
#define LANG_HOOKS_POPLEVEL lhd_do_nothing_iii_return_null_tree
#undef LANG_HOOKS_SET_BLOCK
#define LANG_HOOKS_SET_BLOCK lhd_do_nothing_t
#undef LANG_HOOKS_GETDECLS
#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v
#undef LANG_HOOKS_PUSHDECL
#define LANG_HOOKS_PUSHDECL lhd_return_tree
#undef LANG_HOOKS_FINISH_INCOMPLETE_DECL
#define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
#undef LANG_HOOKS_GET_ALIAS_SET
......@@ -392,6 +398,9 @@ internal_error_function (const char *msgid, va_list *ap)
static bool
gnat_init (void)
{
/* Initialize translations and the outer statement group. */
gnat_init_stmt_group ();
/* Performs whatever initialization steps needed by the language-dependent
lexical analyzer. */
gnat_init_decl_processing ();
......
gcc/ada/trans.c
......@@ -88,6 +88,7 @@ struct stmt_group GTY((chain_next ("%h.previous"))) {
};
static GTY(()) struct stmt_group *current_stmt_group;
static struct stmt_group *global_stmt_group;
/* List of unused struct stmt_group nodes. */
static GTY((deletable)) struct stmt_group *stmt_group_free_list;
......@@ -113,9 +114,8 @@ static GTY(()) tree gnu_loop_label_stack;
TREE_VALUE of each entry is the label at the end of the switch. */
static GTY(()) tree gnu_switch_label_stack;
/* List of TREE_LIST nodes containing pending elaborations lists.
used to prevent the elaborations being reclaimed by GC. */
static GTY(()) tree gnu_pending_elaboration_lists;
/* The FUNCTION_DECL for the elaboration procedure for the main unit. */
static GTY(()) tree gnu_elab_proc_decl;
/* Map GNAT tree codes to GCC tree codes for simple expressions. */
static enum tree_code gnu_codes[Number_Node_Kinds];
......@@ -127,6 +127,8 @@ static void record_code_position (Node_Id);
static void insert_code_for (Node_Id);
static void start_stmt_group (void);
static void add_cleanup (tree);
static tree mark_visited (tree *, int *, void *);
static tree mark_unvisited (tree *, int *, void *);
static tree end_stmt_group (void);
static void add_stmt_list (List_Id);
static tree build_stmt_group (List_Id, bool);
......@@ -148,7 +150,7 @@ 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_1 (tree, int);
static int build_unit_elab (Entity_Id, int, tree);
static bool build_unit_elab (void);
static void annotate_with_node (tree, Node_Id);
/* Constants for +0.5 and -0.5 for float-to-integer rounding. */
......@@ -159,22 +161,13 @@ static REAL_VALUE_TYPE dconstmp5;
structures and then generates code. */
void
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,
struct List_Header *list_headers_ptr,
Int number_units ATTRIBUTE_UNUSED,
char *file_info_ptr ATTRIBUTE_UNUSED,
Entity_Id standard_integer,
Entity_Id standard_long_long_float,
Entity_Id standard_exception_type,
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,
struct List_Header *list_headers_ptr, Int number_units ATTRIBUTE_UNUSED,
char *file_info_ptr ATTRIBUTE_UNUSED, Entity_Id standard_integer,
Entity_Id standard_long_long_float, Entity_Id standard_exception_type,
Int gigi_operating_mode)
{
tree gnu_standard_long_long_float;
......@@ -193,6 +186,10 @@ gigi (Node_Id gnat_root,
type_annotate_only = (gigi_operating_mode == 1);
init_gnat_to_gnu ();
gnat_compute_largest_alignment ();
init_dummy_type ();
/* If we are just annotating types, give VOID_TYPE zero sizes to avoid
errors. */
if (type_annotate_only)
......@@ -204,20 +201,6 @@ gigi (Node_Id gnat_root,
if (Nkind (gnat_root) != N_Compilation_Unit)
gigi_abort (301);
/* Initialize ourselves. */
init_gnat_to_gnu ();
init_dummy_type ();
init_code_table ();
gnat_compute_largest_alignment ();
start_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 ();
/* 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. */
......@@ -226,9 +209,6 @@ gigi (Node_Id gnat_root,
gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
REAL_ARITHMETIC (dconstp5, RDIV_EXPR, dconst1, dconst2);
REAL_ARITHMETIC (dconstmp5, RDIV_EXPR, dconstm1, dconst2);
gnu_standard_long_long_float
= gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
gnu_standard_exception_type
......@@ -251,6 +231,28 @@ gigi (Node_Id gnat_root,
gnat_to_gnu (gnat_root);
}
/* 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);
}
/* This function is the driver of the GNAT to GCC tree transformation
process. It is the entry point of the tree transformer. GNAT_NODE is the
root of some GNAT tree. Return the root of the corresponding GCC tree.
......@@ -263,6 +265,7 @@ gigi (Node_Id gnat_root,
tree
gnat_to_gnu (Node_Id gnat_node)
{
bool went_into_elab_proc = false;
tree gnu_result = error_mark_node; /* Default to no value. */
tree gnu_result_type = void_type_node;
tree gnu_expr;
......@@ -287,6 +290,27 @@ gnat_to_gnu (Node_Id gnat_node)
return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
build_call_raise (CE_Range_Check_Failed));
/* 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. */
if (!current_function_decl
&& ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
&& Nkind (gnat_node) != N_Null_Statement)
|| Nkind (gnat_node) == N_Procedure_Call_Statement
|| Nkind (gnat_node) == N_Label
|| Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
|| ((Nkind (gnat_node) == N_Raise_Constraint_Error
|| Nkind (gnat_node) == N_Raise_Storage_Error
|| Nkind (gnat_node) == N_Raise_Program_Error)
&& (Ekind (Etype (gnat_node)) == E_Void))))
{
current_function_decl = gnu_elab_proc_decl;
start_stmt_group ();
gnat_pushlevel ();
went_into_elab_proc = true;
}
switch (Nkind (gnat_node))
{
/********************************/
......@@ -721,14 +745,11 @@ gnat_to_gnu (Node_Id gnat_node)
{
if ((Is_Public (gnat_temp) || global_bindings_p ())
&& ! TREE_CONSTANT (gnu_expr))
{
gnu_expr
= create_var_decl (create_concat_name (gnat_temp, "init"),
NULL_TREE, TREE_TYPE (gnu_expr),
gnu_expr, 0, Is_Public (gnat_temp), 0,
0, 0);
add_decl_expr (gnu_expr, gnat_temp);
}
gnu_expr
= create_var_decl (create_concat_name (gnat_temp, "init"),
NULL_TREE, TREE_TYPE (gnu_expr),
gnu_expr, 0, Is_Public (gnat_temp), 0,
0, 0, gnat_temp);
else
gnu_expr = maybe_variable (gnu_expr);
......@@ -995,15 +1016,11 @@ gnat_to_gnu (Node_Id gnat_node)
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)
{
gnu_prefix
= create_subprog_decl
(create_concat_name (Entity (Prefix (gnat_node)),
attribute == Attr_Elab_Body
? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, 0, 1, 1, 0);
return gnu_prefix;
}
return (create_subprog_decl
(create_concat_name (Entity (Prefix (gnat_node)),
attribute == Attr_Elab_Body
? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, 0, 1, 1, 0, gnat_node));
gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
gnu_type = TREE_TYPE (gnu_prefix);
......@@ -2272,6 +2289,7 @@ gnat_to_gnu (Node_Id gnat_node)
{
COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
gnu_result = gnu_cond_expr;
recalculate_side_effects (gnu_cond_expr);
}
else
gnu_result = gnu_loop_stmt;
......@@ -2489,31 +2507,14 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
/* We handle pending sizes via the elaboration of types, so we don't
need to save them. This causes them to be marked as part of the
outer function and then discarded. */
get_pending_sizes ();
/* ??? Temporarily do this to avoid GC throwing away outer stuff. */
ggc_push_context ();
/* Set the line number in the decl to correspond to that of
the body so that the line number notes are written
correctly. */
Sloc_to_locus (Sloc (gnat_node),
&DECL_SOURCE_LOCATION (gnu_subprog_decl));
current_function_decl = gnu_subprog_decl;
announce_function (gnu_subprog_decl);
begin_subprog_body (gnu_subprog_decl);
/* Enter a new binding level and show that all the parameters belong to
this function. */
gnat_pushlevel ();
for (gnu_expr = DECL_ARGUMENTS (gnu_subprog_decl); gnu_expr;
gnu_expr = TREE_CHAIN (gnu_expr))
DECL_CONTEXT (gnu_expr) = gnu_subprog_decl;
make_decl_rtl (gnu_subprog_decl, NULL);
gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
/* If there are OUT parameters, we need to ensure that the return
......@@ -2595,8 +2596,6 @@ gnat_to_gnu (Node_Id gnat_node)
}
pop_stack (&gnu_return_label_stack);
if (!type_annotate_only)
add_decl_expr (current_function_decl, gnat_node);
/* Initialize the information node for the function and set the
end location. */
......@@ -2621,7 +2620,6 @@ gnat_to_gnu (Node_Id gnat_node)
mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
write_symbols = save_write_symbols;
debug_hooks = save_debug_hooks;
ggc_pop_context ();
gnu_result = alloc_stmt_list ();
}
break;
......@@ -3151,7 +3149,29 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Compilation_Unit:
start_stmt_group ();
/* 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 ();
/* For a body, first process the spec if there is one. */
if (Nkind (Unit (gnat_node)) == N_Package_Body
......@@ -3169,7 +3189,7 @@ gnat_to_gnu (Node_Id gnat_node)
|| Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
|| Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
{
gnu_result = end_stmt_group ();
gnu_result = alloc_stmt_list ();
break;
}
}
......@@ -3182,17 +3202,19 @@ gnat_to_gnu (Node_Id gnat_node)
add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
/* Generate elaboration code for this unit, if necessary, and
say whether we did or not. */
Set_Has_No_Elaboration_Code
(gnat_node,
build_unit_elab
(Defining_Entity (Unit (gnat_node)),
Nkind (Unit (gnat_node)) == N_Package_Body
|| Nkind (Unit (gnat_node)) == N_Subprogram_Body,
get_pending_elaborations ()));
gnu_result = end_stmt_group ();
/* 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 ();
}
break;
case N_Subprogram_Body_Stub:
......@@ -3258,8 +3280,7 @@ gnat_to_gnu (Node_Id gnat_node)
&& Exception_Mechanism == Setjmp_Longjmp);
bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
/* The statement(s) for the block itself. */
tree gnu_inner_block;
tree gnu_inner_block; /* The statement(s) for the block itself. */
/* If there are any exceptions or cleanup processing involved, we need
an outer statement group (for Setjmp_Longjmp) and binding level. */
......@@ -3285,14 +3306,12 @@ gnat_to_gnu (Node_Id gnat_node)
= create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
jmpbuf_ptr_type,
build_call_0_expr (get_jmpbuf_decl),
0, 0, 0, 0, 0);
0, 0, 0, 0, 0, gnat_node);
gnu_jmpbuf_decl
= create_var_decl (get_identifier ("JMP_BUF"),
NULL_TREE, jmpbuf_type,
NULL_TREE, 0, 0, 0, 0, 0);
NULL_TREE, 0, 0, 0, 0, 0, gnat_node);
add_decl_expr (gnu_jmpsave_decl, gnat_node);
add_decl_expr (gnu_jmpbuf_decl, gnat_node);
set_block_jmpbuf_decl (gnu_jmpbuf_decl);
/* When we exit this block, restore the saved value. */
......@@ -3340,8 +3359,7 @@ gnat_to_gnu (Node_Id gnat_node)
NULL_TREE,
build_pointer_type (except_type_node),
build_call_0_expr (get_excptr_decl),
0, 0, 0, 0, 0));
add_decl_expr (TREE_VALUE (gnu_except_ptr_stack), gnat_node);
0, 0, 0, 0, 0, gnat_node));
/* Generate code for each handler. The N_Exception_Handler case
below does the real work and returns a COND_EXPR for each
......@@ -3602,9 +3620,8 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_incoming_exc_ptr
= create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
ptr_type_node, gnu_current_exc_ptr,
0, 0, 0, 0, 0);
0, 0, 0, 0, 0, gnat_node);
add_decl_expr (gnu_incoming_exc_ptr, gnat_node);
add_stmt_with_node (build_call_1_expr (begin_handler_decl,
gnu_incoming_exc_ptr),
gnat_node);
......@@ -3863,6 +3880,16 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = alloc_stmt_list ();
}
/* If we pushed our level as part of processing the elaboration routine,
pop it back now. */
if (went_into_elab_proc)
{
add_stmt (gnu_result);
gnat_poplevel ();
gnu_result = end_stmt_group ();
current_function_decl = NULL_TREE;
}
/* Set the location information into the result. If we're supposed to
return something of void_type, it means we have something we're
elaborating for effect, so just return. */
......@@ -4030,28 +4057,10 @@ add_stmt (tree gnu_stmt)
{
append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
/* If this is a DECL_EXPR for a variable with DECL_INITIAL set
and decl has a padded type, convert it to the unpadded type so the
assignment is done properly. In other case, the gimplification
of the DECL_EXPR will deal with DECL_INITIAL. */
if (TREE_CODE (gnu_stmt) == DECL_EXPR
&& TREE_CODE (DECL_EXPR_DECL (gnu_stmt)) == VAR_DECL
&& DECL_INITIAL (DECL_EXPR_DECL (gnu_stmt))
&& TREE_CODE (TREE_TYPE (DECL_EXPR_DECL (gnu_stmt))) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (DECL_EXPR_DECL (gnu_stmt))))
{
tree gnu_decl = DECL_EXPR_DECL (gnu_stmt);
tree gnu_lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_decl))), gnu_decl);
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));
add_stmt (gnu_assign_stmt);
}
/* If we're at top level, show everything in here is in use in case
any of it is shared by a subprogram. */
if (!current_function_decl)
walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
}
/* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
......@@ -4070,6 +4079,8 @@ add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
void
add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
{
struct stmt_group *save_stmt_group = current_stmt_group;
/* If this is a variable that Gigi is to ignore, we may have been given
an ERROR_MARK. So test for it. We also might have been given a
reference for a renaming. So only do something for a decl. Also
......@@ -4079,8 +4090,76 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
&& TREE_CODE (TREE_TYPE (gnu_decl)) == UNCONSTRAINED_ARRAY_TYPE))
return;
if (global_bindings_p ())
current_stmt_group = global_stmt_group;
add_stmt_with_node (build (DECL_EXPR, void_type_node, gnu_decl),
gnat_entity);
if (global_bindings_p ())
current_stmt_group = save_stmt_group;
/* If this is a DECL_EXPR for a variable with DECL_INITIAl set,
there are two cases we need to handle here. */
if (TREE_CODE (gnu_decl) == VAR_DECL && DECL_INITIAL (gnu_decl))
{
tree gnu_init = DECL_INITIAL (gnu_decl);
tree gnu_lhs = NULL_TREE;
/* If this is a DECL_EXPR for a variable with DECL_INITIAL set
and decl has a padded type, convert it to the unpadded type so the
assignment is done properly. */
if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (gnu_decl)))
gnu_lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_decl))), gnu_decl);
/* Otherwise, if this is going into memory and the initializer isn't
valid for the assembler and loader. Gimplification could do this,
but would be run too late if -fno-unit-at-a-time. */
else if (TREE_STATIC (gnu_decl)
&& !initializer_constant_valid_p (gnu_init,
TREE_TYPE (gnu_decl)))
gnu_lhs = gnu_decl;
if (gnu_lhs)
{
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));
add_stmt (gnu_assign_stmt);
}
}
}
/* Utility function to mark nodes with TREE_VISITED. Called from walk_tree.
We use this to indicate all variable sizes and positions in global types
may not be shared by any subprogram. */
static tree
mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
{
if (TREE_VISITED (*tp))
*walk_subtrees = 0;
else
TREE_VISITED (*tp) = 1;
return NULL_TREE;
}
/* Likewise, but to mark as unvisited. */
static tree
mark_unvisited (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
{
TREE_VISITED (*tp) = 0;
return NULL_TREE;
}
/* Add GNU_CLEANUP, a cleanup action, to the current code group. */
......@@ -5083,7 +5162,7 @@ process_type (Entity_Id gnat_entity)
{
tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
make_dummy_type (gnat_entity),
0, 0, 0);
0, 0, 0, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, 0);
if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
......@@ -5510,93 +5589,43 @@ gnat_stabilize_reference_1 (tree e, int force)
return result;
}
/* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
either a spec or a body, BODY_P says which. If needed, make a function
to be the elaboration routine for that object and perform the elaborations
in GNU_ELAB_LIST.
/* Take care of building the elaboration procedure for the main unit.
Return 1 if we didn't need an elaboration function, zero otherwise. */
Return true if we didn't need an elaboration function, false otherwise. */
static int
build_unit_elab (Entity_Id gnat_unit, int body_p, tree gnu_elab_list)
static bool
build_unit_elab ()
{
tree gnu_decl;
rtx insn;
int result = 1;
/* ??? For now, force nothing to do. */
gnu_elab_list = 0;
/* If we have nothing to do, return. */
if (gnu_elab_list == 0)
return 1;
/* Prevent the elaboration list from being reclaimed by the GC. */
gnu_pending_elaboration_lists = chainon (gnu_pending_elaboration_lists,
gnu_elab_list);
/* Set our file and line number to that of the object and set up the
elaboration routine. */
gnu_decl = create_subprog_decl (create_concat_name (gnat_unit,
body_p ?
"elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0,
0);
DECL_ELABORATION_PROC_P (gnu_decl) = 1;
begin_subprog_body (gnu_decl);
gnat_pushlevel ();
expand_start_bindings (0);
/* Emit the assignments for the elaborations we have to do. If there
is no destination, this is just a call to execute some statement
that was placed within the declarative region. But first save a
pointer so we can see if any insns were generated. */
insn = get_last_insn ();
for (; gnu_elab_list; gnu_elab_list = TREE_CHAIN (gnu_elab_list))
if (TREE_PURPOSE (gnu_elab_list) == NULL_TREE)
{
if (TREE_VALUE (gnu_elab_list) != 0)
expand_expr_stmt (TREE_VALUE (gnu_elab_list));
}
else
{
tree lhs = TREE_PURPOSE (gnu_elab_list);
input_location = DECL_SOURCE_LOCATION (lhs);
/* If LHS has a padded type, convert it to the unpadded type
so the assignment is done properly. */
if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
emit_line_note (input_location);
expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
TREE_PURPOSE (gnu_elab_list),
TREE_VALUE (gnu_elab_list)));
}
tree body, stmts;
/* See if any non-NOTE insns were generated. */
for (insn = NEXT_INSN (insn); insn; insn = NEXT_INSN (insn))
if (GET_RTX_CLASS (GET_CODE (insn)) == RTX_INSN)
{
result = 0;
break;
}
/* Mark everything we have as not visited. */
walk_tree_without_duplicates (&current_stmt_group->stmt_list,
mark_unvisited, NULL);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
/* Set the current function to be the elaboration procedure, pop our
binding level, end our statement group, and gimplify what we have. */
set_current_block_context (gnu_elab_proc_decl);
gnat_poplevel ();
end_subprog_body (alloc_stmt_list ());
/* We are finished with the elaboration list it can now be discarded. */
gnu_pending_elaboration_lists = TREE_CHAIN (gnu_pending_elaboration_lists);
/* If there were no insns, we don't need an elab routine. It would
be nice to not output this one, but there's no good way to do that. */
return result;
body = end_stmt_group ();
current_function_decl = gnu_elab_proc_decl;
gimplify_body (&body, gnu_elab_proc_decl);
/* We should have a BIND_EXPR, but it may or may not have any statements
in it. If it doesn't have any, we have nothing to do. */
stmts = body;
if (TREE_CODE (stmts) == BIND_EXPR)
stmts = BIND_EXPR_BODY (stmts);
/* If there are no statements, we have nothing to do. */
if (!stmts || !STATEMENT_LIST_HEAD (stmts))
return true;
/* Otherwise, compile the function. Note that we'll be gimplifying
it twice, but that's fine for the nodes we use. */
begin_subprog_body (gnu_elab_proc_decl);
end_subprog_body (body);
return false;
}
extern char *__gnat_to_canonical_file_spec (char *);
......
gcc/ada/utils.c
......@@ -79,21 +79,6 @@ tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
of `save_gnu_tree' for more info. */
static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
/* This listhead is used to record any global objects that need elaboration.
TREE_PURPOSE is the variable to be elaborated and TREE_VALUE is the
initial value to assign. */
static GTY(()) tree pending_elaborations;
/* This stack allows us to momentarily switch to generating elaboration
lists for an inner context. */
struct e_stack GTY((chain_next ("%h.next"))) {
struct e_stack *next;
tree elab_list;
};
static GTY(()) struct e_stack *elist_stack;
/* This variable keeps a table for types for each precision so that we only
allocate each of them once. Signed and unsigned types are kept separate.
......@@ -108,10 +93,10 @@ static GTY(()) tree float_types[NUM_MACHINE_MODES];
/* For each binding contour we allocate a binding_level structure to indicate
the binding depth. */
struct ada_binding_level GTY((chain_next ("%h.chain")))
struct gnat_binding_level GTY((chain_next ("%h.chain")))
{
/* The binding level containing this one (the enclosing binding level). */
struct ada_binding_level *chain;
struct gnat_binding_level *chain;
/* The BLOCK node for this level. */
tree block;
/* If nonzero, the setjmp buffer that needs to be updated for any
......@@ -120,10 +105,10 @@ struct ada_binding_level GTY((chain_next ("%h.chain")))
};
/* The binding level currently in effect. */
static GTY(()) struct ada_binding_level *current_binding_level;
static GTY(()) struct gnat_binding_level *current_binding_level;
/* A chain of ada_binding_level structures awaiting reuse. */
static GTY((deletable)) struct ada_binding_level *free_binding_level;
/* A chain of gnat_binding_level structures awaiting reuse. */
static GTY((deletable)) struct gnat_binding_level *free_binding_level;
/* A chain of unused BLOCK nodes. */
static GTY((deletable)) tree free_block_chain;
......@@ -133,21 +118,20 @@ struct language_function GTY(())
int unused;
};
static tree mark_visited (tree *, int *, void *);
static void gnat_define_builtin (const char *, tree, int, const char *, bool);
static void gnat_install_builtins (void);
static tree merge_sizes (tree, tree, tree, int, int);
static tree merge_sizes (tree, tree, tree, bool, bool);
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
static int value_zerop (tree);
static bool value_zerop (tree);
static void gnat_gimplify_function (tree);
static void gnat_finalize (tree);
static tree float_type_for_precision (int, enum machine_mode);
static tree convert_to_fat_pointer (tree, tree);
static tree convert_to_thin_pointer (tree, tree);
static tree make_descriptor_field (const char *,tree, tree, tree);
static int value_factor_p (tree, int);
static int potential_alignment_gap (tree, tree, tree);
static bool value_factor_p (tree, HOST_WIDE_INT);
static bool potential_alignment_gap (tree, tree, tree);
/* Initialize the association of GNAT nodes to GCC trees. */
......@@ -156,8 +140,6 @@ init_gnat_to_gnu (void)
{
associate_gnat_to_gnu
= (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
}
/* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
......@@ -211,16 +193,8 @@ present_gnu_tree (Entity_Id gnat_entity)
int
global_bindings_p (void)
{
return (force_global != 0 || current_binding_level->chain == 0 ? -1 : 0);
}
/* Return the list of declarations in the current level. Note that this list
is in reverse order (it has to be so for back-end compatibility). */
tree
getdecls (void)
{
return BLOCK_VARS (current_binding_level->block);
return (force_global != 0 || current_binding_level == 0
|| current_binding_level->chain == 0 ? -1 : 0);
}
/* Enter a new binding level. */
......@@ -228,7 +202,7 @@ getdecls (void)
void
gnat_pushlevel ()
{
struct ada_binding_level *newlevel = NULL;
struct gnat_binding_level *newlevel = NULL;
/* Reuse a struct for this binding level, if there is one. */
if (free_binding_level)
......@@ -238,8 +212,8 @@ gnat_pushlevel ()
}
else
newlevel
= (struct ada_binding_level *)
ggc_alloc (sizeof (struct ada_binding_level));
= (struct gnat_binding_level *)
ggc_alloc (sizeof (struct gnat_binding_level));
/* Use a free BLOCK, if any; otherwise, allocate one. */
if (free_block_chain)
......@@ -264,6 +238,16 @@ gnat_pushlevel ()
current_binding_level = newlevel;
}
/* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
and point FNDECL to this BLOCK. */
void
set_current_block_context (tree fndecl)
{
BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
DECL_INITIAL (fndecl) = current_binding_level->block;
}
/* Set the jmpbuf_decl for the current binding level to DECL. */
void
......@@ -285,7 +269,7 @@ get_block_jmpbuf_decl ()
void
gnat_poplevel ()
{
struct ada_binding_level *level = current_binding_level;
struct gnat_binding_level *level = current_binding_level;
tree block = level->block;
BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
......@@ -329,59 +313,33 @@ insert_block (tree block)
TREE_CHAIN (block) = BLOCK_SUBBLOCKS (current_binding_level->block);
BLOCK_SUBBLOCKS (current_binding_level->block) = block;
}
/* Return nonzero if the current binding has any variables. This means
it will have a BLOCK node. */
int
block_has_vars ()
{
return BLOCK_VARS (current_binding_level->block) != 0;
}
/* Utility function to mark nodes with TREE_VISITED. Called from walk_tree.
We use this to indicate all variable sizes and positions in global types
may not be shared by any subprogram. */
static tree
mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
{
if (TREE_VISITED (*tp))
*walk_subtrees = 0;
else
TREE_VISITED (*tp) = 1;
return NULL_TREE;
}
/* Records a ..._DECL node DECL as belonging to the current lexical scope.
Returns the ..._DECL node. */
/* Records a ..._DECL node DECL as belonging to the current lexical scope
and uses GNAT_NODE for location information. */
tree
pushdecl (tree decl)
void
gnat_pushdecl (tree decl, Node_Id gnat_node)
{
/* If at top level, there is no context. But PARM_DECLs always go in the
level of its function. Also, at toplevel we must protect all trees
that are part of sizes and positions. */
level of its function. */
if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
{
/* Make a DECL_EXPR so we'll walk into the appropriate fields of
the type or decl. */
tree decl_expr = build1 (DECL_EXPR, void_type_node, decl);
DECL_CONTEXT (decl) = 0;
walk_tree (&decl_expr, mark_visited, NULL, NULL);
}
DECL_CONTEXT (decl) = 0;
else
DECL_CONTEXT (decl) = current_function_decl;
/* Put the declaration on the list. The list of declarations is in reverse
order. The list will be reversed later.
/* Set the location of DECL and emit a declaration for it. */
if (Present (gnat_node))
Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl));
add_decl_expr (decl, gnat_node);
Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the list. They
will cause trouble with the debugger and aren't needed anyway. */
if (TREE_CODE (decl) != TYPE_DECL
|| TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
/* Put the declaration on the list. The list of declarations is in reverse
order. The list will be reversed later. We don't do this for global
variables. Also, don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into
the list. They will cause trouble with the debugger and aren't needed
anyway. */
if (!global_bindings_p ()
&& (TREE_CODE (decl) != TYPE_DECL
|| TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE))
{
TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
BLOCK_VARS (current_binding_level->block) = decl;
......@@ -404,8 +362,9 @@ pushdecl (tree decl)
&& DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl)))
&& ! DECL_ARTIFICIAL (decl))))
TYPE_NAME (TREE_TYPE (decl)) = decl;
return decl;
if (TREE_CODE (decl) != CONST_DECL)
rest_of_decl_compilation (decl, NULL, global_bindings_p (), 0);
}
/* Do little here. Set up the standard declarations later after the
......@@ -433,14 +392,21 @@ gnat_init_decl_processing (void)
set_sizetype (size_type_node);
build_common_tree_nodes_2 (0);
pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype));
/* We need to make the integer type before doing anything else.
We stitch this in to the appropriate GNAT type later. */
pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
integer_type_node));
pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
char_type_node));
/* Give names and make TYPE_DECLs for common types. */
gnat_pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype),
Empty);
gnat_pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
integer_type_node),
Empty);
gnat_pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
char_type_node),
Empty);
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);
......@@ -462,7 +428,7 @@ gnat_define_builtin (const char *name, tree type,
if (library_name)
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
make_decl_rtl (decl, NULL);
pushdecl (decl);
gnat_pushdecl (decl, Empty);
DECL_BUILT_IN_CLASS (decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (decl) = function_code;
TREE_READONLY (decl) = const_p;
......@@ -540,7 +506,6 @@ gnat_install_builtins ()
BUILT_IN_STACK_RESTORE, "stack_restore", false);
}
/* Create the predefined scalar types such as `integer_type_node' needed
in the gcc back-end and initialize the global binding level. */
......@@ -560,8 +525,8 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
longest_float_type_node = make_node (REAL_TYPE);
TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
layout_type (longest_float_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("longest float type"),
longest_float_type_node));
create_type_decl (get_identifier ("longest float type"),
longest_float_type_node, NULL, 0, 1, Empty);
}
else
longest_float_type_node = TREE_TYPE (long_long_float_type);
......@@ -569,12 +534,11 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
except_type_node = TREE_TYPE (exception_type);
unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
unsigned_type_node));
create_type_decl (get_identifier ("unsigned int"), unsigned_type_node,
NULL, 0, 1, Empty);
void_type_decl_node
= pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
void_type_node));
void_type_decl_node = create_type_decl (get_identifier ("void"),
void_type_node, NULL, 0, 1, Empty);
void_ftype = build_function_type (void_type_node, NULL_TREE);
ptr_void_ftype = build_pointer_type (void_ftype);
......@@ -590,7 +554,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
tree_cons (NULL_TREE,
sizetype,
endlink)),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
/* free is a function declaration tree for a function to free memory. */
free_decl
......@@ -599,13 +563,14 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
tree_cons (NULL_TREE,
ptr_void_type_node,
endlink)),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
/* Make the types and functions used for exception processing. */
jmpbuf_type
= build_array_type (gnat_type_for_mode (Pmode, 0),
build_index_type (build_int_2 (5, 0)));
pushdecl (build_decl (TYPE_DECL, get_identifier ("JMPBUF_T"), jmpbuf_type));
create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL,
0, 1, Empty);
jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
/* Functions to get and set the jumpbuf pointer for the current thread. */
......@@ -613,7 +578,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
= create_subprog_decl
(get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
set_jmpbuf_decl
= create_subprog_decl
......@@ -621,7 +586,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
/* Function to get the current exception. */
get_excptr_decl
......@@ -629,7 +594,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
(get_identifier ("system__soft_links__get_gnat_exception"),
NULL_TREE,
build_function_type (build_pointer_type (except_type_node), NULL_TREE),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
/* Functions that raise exceptions. */
raise_nodefer_decl
......@@ -639,7 +604,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
tree_cons (NULL_TREE,
build_pointer_type (except_type_node),
endlink)),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
/* Hooks to call when entering/leaving an exception handler. */
begin_handler_decl
......@@ -648,7 +613,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
tree_cons (NULL_TREE,
ptr_void_type_node,
endlink)),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
end_handler_decl
= create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
......@@ -656,7 +621,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
tree_cons (NULL_TREE,
ptr_void_type_node,
endlink)),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
/* If in no exception handlers mode, all raise statements are redirected to
__gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
......@@ -672,7 +637,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
tree_cons (NULL_TREE,
integer_type_node,
endlink))),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
gnat_raise_decls[i] = decl;
......@@ -694,7 +659,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
tree_cons (NULL_TREE,
integer_type_node,
endlink))),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
}
/* Indicate that these never return. */
......@@ -720,7 +685,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
(get_identifier ("__builtin_setjmp"), NULL_TREE,
build_function_type (integer_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
......@@ -732,7 +697,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
(get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
NULL_TREE, 0, 1, 1, 0);
NULL_TREE, 0, 1, 1, 0, Empty);
DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
......@@ -740,17 +705,14 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
main_identifier_node = get_identifier ("main");
}
/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
nodes (FIELDLIST), finish constructing the record or union type.
If HAS_REP is nonzero, this record has a rep clause; don't call
layout_type but merely set the size and alignment ourselves.
If DEFER_DEBUG is nonzero, do not call the debugging routines
on this type; it will be done later. */
/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL nodes
(FIELDLIST), finish constructing the record or union type. If HAS_REP is
nonzero, this record has a rep clause; don't call layout_type but merely set
the size and alignment ourselves. If DEFER_DEBUG is nonzero, do not call
the debugging routines on this type; it will be done later. */
void
finish_record_type (tree record_type,
tree fieldlist,
int has_rep,
finish_record_type (tree record_type, tree fieldlist, int has_rep,
int defer_debug)
{
enum tree_code code = TREE_CODE (record_type);
......@@ -761,14 +723,8 @@ finish_record_type (tree record_type,
tree field;
TYPE_FIELDS (record_type) = fieldlist;
if (TYPE_NAME (record_type) != 0
&& TREE_CODE (TYPE_NAME (record_type)) == TYPE_DECL)
TYPE_STUB_DECL (record_type) = TYPE_NAME (record_type);
else
TYPE_STUB_DECL (record_type)
= pushdecl (build_decl (TYPE_DECL, TYPE_NAME (record_type),
record_type));
TYPE_STUB_DECL (record_type)
= build_decl (TYPE_DECL, NULL_TREE, record_type);
/* We don't need both the typedef name and the record name output in
the debugging information, since they are the same. */
......@@ -942,7 +898,10 @@ finish_record_type (tree record_type,
tree new_record_type
= make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
? UNION_TYPE : TREE_CODE (record_type));
tree orig_id = DECL_NAME (TYPE_STUB_DECL (record_type));
tree orig_name = TYPE_NAME (record_type);
tree orig_id
= (TREE_CODE (orig_name) == TYPE_DECL ? DECL_NAME (orig_name)
: orig_name);
tree new_id
= concat_id_with_name (orig_id,
TREE_CODE (record_type) == QUAL_UNION_TYPE
......@@ -954,7 +913,7 @@ finish_record_type (tree record_type,
TYPE_NAME (new_record_type) = new_id;
TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
TYPE_STUB_DECL (new_record_type)
= pushdecl (build_decl (TYPE_DECL, new_id, new_record_type));
= build_decl (TYPE_DECL, NULL_TREE, new_record_type);
DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1;
DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
= DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
......@@ -1086,11 +1045,8 @@ finish_record_type (tree record_type,
We return an expression for the size. */
static tree
merge_sizes (tree last_size,
tree first_bit,
tree size,
int special,
int has_rep)
merge_sizes (tree last_size, tree first_bit, tree size, bool special,
bool has_rep)
{
tree type = TREE_TYPE (last_size);
tree new;
......@@ -1188,13 +1144,9 @@ split_plus (tree in, tree *pvar)
object. RETURNS_BY_REF is nonzero if the function returns by reference.
RETURNS_WITH_DSP is nonzero if the function is to return with a
depressed stack pointer. */
tree
create_subprog_type (tree return_type,
tree param_decl_list,
tree cico_list,
int returns_unconstrained,
int returns_by_ref,
create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
int returns_unconstrained, int returns_by_ref,
int returns_with_dsp)
{
/* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
......@@ -1275,7 +1227,7 @@ create_index_type (tree min, tree max, tree index)
type = copy_type (type);
SET_TYPE_INDEX_TYPE (type, index);
add_decl_expr (create_type_decl (NULL_TREE, type, NULL, 1, 0), Empty);
create_type_decl (NULL_TREE, type, NULL, 1, 0, Empty);
return type;
}
......@@ -1283,17 +1235,18 @@ create_index_type (tree min, tree max, tree index)
string) and TYPE is a ..._TYPE node giving its data type.
ARTIFICIAL_P is nonzero if this is a declaration that was generated
by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging
information about this type. */
information about this type. GNAT_NODE is used for the position of
the decl. */
tree
create_type_decl (tree type_name, tree type, struct attrib *attr_list,
int artificial_p, int debug_info_p)
int artificial_p, int debug_info_p, Node_Id gnat_node)
{
tree type_decl = build_decl (TYPE_DECL, type_name, type);
enum tree_code code = TREE_CODE (type);
DECL_ARTIFICIAL (type_decl) = artificial_p;
pushdecl (type_decl);
process_attributes (type_decl, attr_list);
/* Pass type declaration information to the debugger unless this is an
......@@ -1309,6 +1262,9 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list,
&& TYPE_IS_DUMMY_P (TREE_TYPE (type))))
rest_of_decl_compilation (type_decl, NULL, global_bindings_p (), 0);
if (!TYPE_IS_DUMMY_P (type))
gnat_pushdecl (type_decl, gnat_node);
return type_decl;
}
......@@ -1326,12 +1282,14 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list,
definition: no storage is to be allocated for the variable here).
STATIC_FLAG is only relevant when not at top level. In that case
it indicates whether to always allocate storage to the variable. */
it indicates whether to always allocate storage to the variable.
GNAT_NODE is used for the position of the decl. */
tree
create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
int const_flag, int public_flag, int extern_flag,
int static_flag, struct attrib *attr_list)
int static_flag, struct attrib *attr_list, Node_Id gnat_node)
{
int init_const
= (var_init == 0
......@@ -1357,17 +1315,10 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
save any variable elaborations for the elaboration routine. If we are
just annotating types, throw away the initialization if it isn't a
constant. */
if ((extern_flag && TREE_CODE (var_decl) != CONST_DECL)
|| (type_annotate_only && var_init != 0 && ! TREE_CONSTANT (var_init)))
var_init = 0;
if (global_bindings_p () && var_init != 0 && ! init_const)
{
add_pending_elaborations (var_decl, var_init);
var_init = 0;
}
DECL_INITIAL (var_decl) = var_init;
TREE_READONLY (var_decl) = const_flag;
DECL_EXTERNAL (var_decl) = extern_flag;
......@@ -1386,9 +1337,8 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
process_attributes (var_decl, attr_list);
/* Add this decl to the current binding level and generate any
needed code and RTL. */
var_decl = pushdecl (var_decl);
/* Add this decl to the current binding level. */
gnat_pushdecl (var_decl, gnat_node);
if (TREE_SIDE_EFFECTS (var_decl))
TREE_ADDRESSABLE (var_decl) = 1;
......@@ -1407,13 +1357,8 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
the address of this field for aliasing purposes. */
tree
create_field_decl (tree field_name,
tree field_type,
tree record_type,
int packed,
tree size,
tree pos,
int addressable)
create_field_decl (tree field_name, tree field_type, tree record_type,
int packed, tree size, tree pos, int addressable)
{
tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
......@@ -1540,7 +1485,7 @@ create_field_decl (tree field_name,
/* Subroutine of previous function: return nonzero if EXP, ignoring any side
effects, has the value of zero. */
static int
static bool
value_zerop (tree exp)
{
if (TREE_CODE (exp) == COMPOUND_EXPR)
......@@ -1629,36 +1574,11 @@ process_attributes (tree decl, struct attrib *attr_list)
}
}
/* Add some pending elaborations on the list. */
/* Return true if VALUE is a known to be a multiple of FACTOR, which must be
a power of 2. */
void
add_pending_elaborations (tree var_decl, tree var_init)
{
if (var_init != 0)
Check_Elaboration_Code_Allowed (error_gnat_node);
pending_elaborations
= chainon (pending_elaborations, build_tree_list (var_decl, var_init));
}
/* Obtain any pending elaborations and clear the old list. */
tree
get_pending_elaborations (void)
{
/* Each thing added to the list went on the end; we want it on the
beginning. */
tree result = TREE_CHAIN (pending_elaborations);
TREE_CHAIN (pending_elaborations) = 0;
return result;
}
/* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power
of 2. */
static int
value_factor_p (tree value, int factor)
static bool
value_factor_p (tree value, HOST_WIDE_INT factor)
{
if (host_integerp (value, 1))
return tree_low_cst (value, 1) % factor == 0;
......@@ -1676,7 +1596,7 @@ value_factor_p (tree value, int factor)
is the distance in bits between the end of PREV_FIELD and the starting
position of CURR_FIELD. It is ignored if null. */
static int
static bool
potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
{
/* If this is the first field of the record, there cannot be any gap */
......@@ -1716,64 +1636,6 @@ potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
return 1;
}
/* Return nonzero if there are pending elaborations. */
int
pending_elaborations_p (void)
{
return TREE_CHAIN (pending_elaborations) != 0;
}
/* Save a copy of the current pending elaboration list and make a new
one. */
void
push_pending_elaborations (void)
{
struct e_stack *p = (struct e_stack *) ggc_alloc (sizeof (struct e_stack));
p->next = elist_stack;
p->elab_list = pending_elaborations;
elist_stack = p;
pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
}
/* Pop the stack of pending elaborations. */
void
pop_pending_elaborations (void)
{
struct e_stack *p = elist_stack;
pending_elaborations = p->elab_list;
elist_stack = p->next;
}
/* Return the current position in pending_elaborations so we can insert
elaborations after that point. */
tree
get_elaboration_location (void)
{
return tree_last (pending_elaborations);
}
/* Insert the current elaborations after ELAB, which is in some elaboration
list. */
void
insert_elaboration_list (tree elab)
{
tree next = TREE_CHAIN (elab);
if (TREE_CHAIN (pending_elaborations))
{
TREE_CHAIN (elab) = TREE_CHAIN (pending_elaborations);
TREE_CHAIN (tree_last (pending_elaborations)) = next;
TREE_CHAIN (pending_elaborations) = 0;
}
}
/* Returns a LABEL_DECL node for LABEL_NAME. */
tree
......@@ -1794,17 +1656,13 @@ create_label_decl (tree label_name)
PARM_DECL nodes chained through the TREE_CHAIN field).
INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
appropriate fields in the FUNCTION_DECL. */
appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */
tree
create_subprog_decl (tree subprog_name,
tree asm_name,
tree subprog_type,
tree param_decl_list,
int inline_flag,
int public_flag,
int extern_flag,
struct attrib *attr_list)
create_subprog_decl (tree subprog_name, tree asm_name,
tree subprog_type, tree param_decl_list, int inline_flag,
int public_flag, int extern_flag,
struct attrib *attr_list, Node_Id gnat_node)
{
tree return_type = TREE_TYPE (subprog_type);
tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
......@@ -1834,7 +1692,7 @@ create_subprog_decl (tree subprog_name,
process_attributes (subprog_decl, attr_list);
/* Add this decl to the current binding level. */
subprog_decl = pushdecl (subprog_decl);
gnat_pushdecl (subprog_decl, gnat_node);
/* Output the assembler code and/or RTL for the declaration. */
rest_of_decl_compilation (subprog_decl, 0, global_bindings_p (), 0);
......@@ -1842,12 +1700,6 @@ create_subprog_decl (tree subprog_name,
return subprog_decl;
}
/* Count how deep we are into nested functions. This is because
we shouldn't call the backend function context routines unless we
are in a nested function. */
static int function_nesting_depth;
/* Set up the framework for generating code for SUBPROG_DECL, a subprogram
body. This routine needs to be invoked before processing the declarations
appearing in the subprogram. */
......@@ -1857,30 +1709,22 @@ begin_subprog_body (tree subprog_decl)
{
tree param_decl;
if (function_nesting_depth++ != 0)
push_function_context ();
current_function_decl = subprog_decl;
announce_function (subprog_decl);
/* Make this field nonzero so further routines know that this is not
tentative. error_mark_node is replaced below with the adequate BLOCK. */
DECL_INITIAL (subprog_decl) = error_mark_node;
/* This function exists in static storage. This does not mean `static' in
the C sense! */
TREE_STATIC (subprog_decl) = 1;
/* Enter a new binding level and show that all the parameters belong to
this function. */
current_function_decl = subprog_decl;
gnat_pushlevel ();
for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
param_decl = TREE_CHAIN (param_decl))
DECL_CONTEXT (param_decl) = subprog_decl;
init_function_start (subprog_decl);
expand_function_start (subprog_decl, 0);
make_decl_rtl (subprog_decl, NULL);
/* We handle pending sizes via the elaboration of types, so we don't need to
save them. This causes them to be marked as part of the outer function
and then discarded. */
get_pending_sizes ();
}
/* Finish the definition of the current subprogram and compile it all the way
......@@ -1978,11 +1822,8 @@ gnat_finalize (tree fndecl)
ATTRS is nonzero, use that for the function attribute list. */
tree
builtin_function (const char *name,
tree type,
int function_code,
enum built_in_class class,
const char *library_name,
builtin_function (const char *name, tree type, int function_code,
enum built_in_class class, const char *library_name,
tree attrs)
{
tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
......@@ -1992,7 +1833,7 @@ builtin_function (const char *name,
if (library_name)
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
pushdecl (decl);
gnat_pushdecl (decl, Empty);
DECL_BUILT_IN_CLASS (decl) = class;
DECL_FUNCTION_CODE (decl) = function_code;
if (attrs)
......@@ -2295,7 +2136,7 @@ build_template (tree template_type, tree array_type, tree expr)
/* Build a VMS descriptor from a Mechanism_Type, which must specify
a descriptor type, and the GCC type of an object. Each FIELD_DECL
in the type contains in its DECL_INITIAL the expression to use when
a constructor is made for the type. GNAT_ENTITY is a gnat node used
a constructor is made for the type. GNAT_ENTITY is an entity used
to print out an error message if the mechanism cannot be applied to
an object of that type and also for the name. */
......@@ -2581,8 +2422,8 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
}
finish_record_type (record_type, field_list, 0, 1);
pushdecl (build_decl (TYPE_DECL, create_concat_name (gnat_entity, "DESC"),
record_type));
create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type,
NULL, 1, 0, gnat_entity);
return record_type;
}
......
gcc/ada/utils2.c
......@@ -1751,9 +1751,10 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
tree gnu_range
= build_range_type (NULL_TREE, size_one_node, gnu_size);
tree gnu_array_type = build_array_type (char_type_node, gnu_range);
tree gnu_decl =
create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
gnu_array_type, NULL_TREE, 0, 0, 0, 0, 0);
tree gnu_decl
= create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
gnu_array_type, NULL_TREE, 0, 0, 0, 0, 0,
gnat_node);
return convert (ptr_void_type_node,
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl));
......@@ -1779,12 +1780,8 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
the storage pool to use. */
tree
build_allocator (tree type,
tree init,
tree result_type,
Entity_Id gnat_proc,
Entity_Id gnat_pool,
Node_Id gnat_node)
build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
Entity_Id gnat_pool, Node_Id gnat_node)
{
tree size = TYPE_SIZE_UNIT (type);
tree result;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment