From 909f21b39e4d27523d76258a039fd79911f11494 Mon Sep 17 00:00:00 2001 From: Richard Kenner Date: Mon, 28 Jun 2004 21:37:16 +0000 Subject: [PATCH] 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 --- gcc/ada/ChangeLog | 47 ++++++ gcc/ada/decl.c | 155 ++++++++----------- gcc/ada/gigi.h | 39 +++-- gcc/ada/misc.c | 9 ++ gcc/ada/trans.c | 433 ++++++++++++++++++++++++++++------------------------- gcc/ada/utils.c | 439 +++++++++++++++++------------------------------------- gcc/ada/utils2.c | 15 +- 7 files changed, 511 insertions(+), 626 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f3318a6..22d0644 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2004-06-28 Richard Kenner + + * 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 * mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb, diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 0fd4c2b..5ef6ef5 100644 --- a/gcc/ada/decl.c +++ b/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) diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h index 6e64aa4..e633341 100644 --- a/gcc/ada/gigi.h +++ b/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); diff --git a/gcc/ada/misc.c b/gcc/ada/misc.c index 0cb8905..5f2200b 100644 --- a/gcc/ada/misc.c +++ b/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 (); diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index a7c1085..5992ce7 100644 --- a/gcc/ada/trans.c +++ b/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, ¤t_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 (¤t_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 *); diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index 53823e8..5a0d558 100644 --- a/gcc/ada/utils.c +++ b/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; } diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c index f1c167f..0a563a5 100644 --- a/gcc/ada/utils2.c +++ b/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; -- 2.7.4