Skip to content

R
riscv-gcc-1
Commit c8945d56 by Eric Botcazou Committed by Arnaud Charlet
Options

gigi.h: (tree_code_for_record_type): Declare. 

2006-10-31  Eric Botcazou  <ebotcazou@adacore.com>
	    Nicolas Setton  <setton@adacore.com>
	    Olivier Hainque  <hainque@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* gigi.h: (tree_code_for_record_type): Declare.
	(add_global_renaming_pointer): Rename to record_global_renaming_pointer.
	(get_global_renaming_pointers): Rename to
	invalidate_global_renaming_pointers.
	(static_ctors): Delete.
	(static_dtors): Likewise.
	(gnat_write_global_declarations): Declare.
	(create_var_decl): Adjust descriptive comment to indicate that the
	subprogram may return a CONST_DECL node.
	(create_true_var_decl): Declare new function, similar to
	create_var_decl but forcing the creation of a VAR_DECL node.
	(get_global_renaming_pointers): Declare.
	(add_global_renaming_pointer): Likewise.

	* ada-tree.h (DECL_READONLY_ONCE_ELAB): New macro.

	* decl.c (gnat_to_gnu_entity) <case E_Function>: Don't copy the type
	tree before setting TREE_ADDRESSABLE for by-reference return mechanism
	processing.
	(gnat_to_gnu_entity): Remove From_With_Type from computation for
	imported_p.
	<E_Access_Type>: Use the Non_Limited_View as the full view of the
	designated type if the pointer comes from a limited_with clause.  Make
	incomplete designated type if it is in the main unit and has a freeze
	node.
	<E_Incomplete_Type>: Rework to treat Non_Limited_View, Full_View, and
	Underlying_Full_View similarly.  Return earlier if the full view already
	has an associated tree.
	(gnat_to_gnu_entity) <E_Record_Type>: Restore comment.
	(gnat_to_gnu_entity) <E_Record_Type>: Do not use a dummy type.
	(gnat_to_gnu_entity) <E_Variable>: Set TYPE_REF_CAN_ALIAS_ALL on the
	reference type built for objects with an address clause.
	Use create_true_var_decl with const_flag set for
	DECL_CONST_CORRESPONDING_VARs, ensuring a VAR_DECL is created with
	TREE_READONLY set.
	(gnat_to_gnu_entity, case E_Enumeration_Type): Set TYPE_NAME
	for Character and Wide_Character types. This info is read by the
	dwarf-2 writer, and is needed to be able to use the command "ptype
	character" in the debugger.
	(gnat_to_gnu_entity): When generating a type representing
	a Character or Wide_Character type, set the flag TYPE_STRING_FLAG,
	so that debug writers can distinguish it from ordinary integers.
	(elaborate_expression_1): Test the DECL_READONLY_ONCE_ELAB flag in
	addition to TREE_READONLY to assert the constantness of variables for
	elaboration purposes.
	(gnat_to_gnu_entity, subprogram cases): Change loops on formal
	parameters to call new Einfo function First_Formal_With_Extras.
	(gnat_to_gnu_entity): In type_annotate mode, replace a discriminant of a
	protected type with its corresponding discriminant, to obtain a usable
	declaration
	(gnat_to_gnu_entity) <E_Access_Protected_Subprogram_Type>: Be prepared
	for a multiple elaboration of the "equivalent" type.
	(gnat_to_gnu_entity): Adjust for renaming of add_global_renaming_pointer
	into record_global_renaming_pointer.
	(gnat_to_gnu_entity) <E_Array_Type>: Do not force
	TYPE_NONALIASED_COMPONENT to 0 if the element type is an aggregate.
	<E_Array_Subtype>: Likewise.
	(gnat_to_gnu_entity) <E_Incomplete_Subtype>: Add support for regular
	incomplete subtypes and incomplete subtypes of incomplete types visible
	through a limited with clause.
	(gnat_to_gnu_entity) <E_Array_Subtype>: Take into account the bounds of
	the base index type for the maximum size of the array only if they are
	constant.
	(gnat_to_gnu_entity, renaming object case): Do not wrap up the
	expression into a SAVE_EXPR if stabilization failed.

	* utils.c (create_subprog_decl): Turn TREE_ADDRESSABLE on the type of
	a result decl into DECL_BY_REFERENCE on this decl, now what is expected
	by lower level compilation passes.
	(gnat_genericize): New function, lowering a function body to GENERIC.
	Turn the type of RESULT_DECL into a real reference type if the decl
	has been marked DECL_BY_REFERENCE, and adjust references to the latter
	accordingly.
	(gnat_genericize_r): New function. Tree walking callback for
	gnat_genericize.
	(convert_from_reference, is_byref_result): New functions. Helpers for
	gnat_genericize_r.
	(create_type_decl): Call gnat_pushdecl before calling
	rest_of_decl_compilation, to make sure that field TYPE_NAME of
	type_decl is properly set before calling the debug information writers.
	(write_record_type_debug_info): The heuristics which compute the
	alignment of a field in a variant record might not be accurate. Add a
	safety test to make sure no alignment is set to a smaller value than
	the alignment of the field type.
	(make_dummy_type): Use the Non_Limited_View as the underlying type if
	the type comes from a limited_with clause. Do not loop on the full view.
	(GET_GNU_TREE, SET_GNU_TREE, PRESENT_GNU_TREE): New macros.
	(dummy_node_table): New global variable, moved from decl.c.
	(GET_DUMMY_NODE, SET_DUMMY_NODE, PRESENT_DUMMY_NODE): New macros.
	(save_gnu_tree): Use above macros.
	(get_gnu_tree): Likewise.
	(present_gnu_tree): Likewise.
	(init_dummy_type): New function, moved from decl.c. Use above macros.
	(make_dummy_type): Likewise.
	(tree_code_for_record_type): New function extracted from make_dummy_type
	(init_gigi_decls): Set DECL_IS_MALLOC on gnat_malloc.
	(static_ctors): Change it to a vector, make static.
	(static_dtors): Likewise.
	(end_subprog_body): Adjust for above change.
	(build_global_cdtor): Moved from trans.c.
	(gnat_write_global_declarations): Emit global constructor and
	destructor, and call cgraph_optimize before emitting debug info for
	global declarations.
	(global_decls): New global variable.
	(gnat_pushdecl): Store the global declarations in global_decls, for
	later use.
	(gnat_write_global_declarations): Emit debug information for global
	 declarations.
	(create_var_decl_1): Former create_var_decl, with an extra argument to
	 state whether the creation of a CONST_DECL is allowed.
	(create_var_decl): Behavior unchanged. Now a wrapper around
	create_var_decl_1 allowing CONST_DECL creation.
	(create_true_var_decl): New function, similar to create_var_decl but
	forcing the creation of a VAR_DECL node (CONST_DECL not allowed).
	(create_field_decl): Do not always mark the field as addressable
	if its type is an aggregate.
	(global_renaming_pointers): New static variable.
	(add_global_renaming_pointer): New function.
	(get_global_renaming_pointers): Likewise.

	* misc.c (gnat_dwarf_name): New function.
	(LANG_HOOKS_DWARF_NAME): Define to gnat_dwarf_name.
	(gnat_post_options): Add comment about structural alias analysis.
	(gnat_parse_file): Do not call cgraph_optimize here.
	(LANG_HOOKS_WRITE_GLOBALS): Define to gnat_write_global_declarations.

	* trans.c (process_freeze_entity): Don't abort if we already have a
	non dummy GCC tree for a Concurrent_Record_Type, as it might
	legitimately have been elaborated while processing the associated
	Concurrent_Type prior to this explicit freeze node.
	(Identifier_to_gnu): Do not make a variable referenced in a SJLJ
	exception handler volatile if it is of variable size.
	(process_type): Remove bypass for types coming from a limited_with
	clause.
	(call_to_gnu): When processing the copy-out of a N_Type_Conversion GNAT
	actual, convert the corresponding gnu_actual to the real destination
	type when necessary.
	(add_decl_expr): Set the DECL_READONLY_ONCE_ELAB flag on variables
	originally TREE_READONLY but whose elaboration cannot be performed
	statically.
	Part of fix for F504-021.
	(tree_transform, subprogram cases): Change loops on formal parameters to
	call new Einfo function First_Formal_With_Extras.
	(gnat_to_gnu) <N_Op_Shift_Right_Arithmetic>: Ignore constant overflow
	stemming from type conversion for the lhs.
	(Attribute_to_gnu) <Attr_Alignment>: Also divide the alignment by the
	number of bits per unit for components of records.
	(gnat_to_gnu) <N_Code_Statement>: Mark operands addressable if needed.
	(Handled_Sequence_Of_Statements_to_gnu): Register the cleanup associated
	with At_End_Proc after the SJLJ EH cleanup.
	(Compilation_Unit_to_gnu): Call elaborate_all_entities only on the main
	compilation unit.
	(elaborate_all_entities): Do not retest type_annotate_only.
	(tree_transform) <N_Abstract_Subprogram_Declaration>: Process the
	result type of an abstract subprogram, which may be an itype associated
	with an anonymous access result (related to AI-318-02).
	(build_global_cdtor): Move to utils.c.
	(Case_Statement_to_gnu): Avoid adding the choice of a when statement if
	this choice is not a null tree nor an integer constant.
	(gigi): Run unshare_save_expr via walk_tree_without_duplicates
	on the body of elaboration routines instead of mark_unvisited.
	(add_stmt): Do not mark the tree.
	(add_decl_expr): Tweak comment.
	(mark_unvisited): Delete.
	(unshare_save_expr): New static function.
	(call_to_gnu): Issue an error when making a temporary around a
	procedure call because of non-addressable actual parameter if the
	type of the formal is by_reference.
	(Compilation_Unit_to_gnu): Invalidate the global renaming pointers
	after building the elaboration routine.

From-SVN: r118331
parent bfc8aa81
Showing with 949 additions and 464 deletions
gcc/ada/ada-tree.h
......@@ -232,6 +232,10 @@ struct lang_type GTY(()) {tree t; };
discriminant. */
#define DECL_STUBBED_P(NODE) DECL_LANG_FLAG_0 (FUNCTION_DECL_CHECK (NODE))
/* Nonzero in a VAR_DECL if it is guaranteed to be constant after having
been elaborated and TREE_READONLY is not set on it. */
#define DECL_READONLY_ONCE_ELAB(NODE) DECL_LANG_FLAG_0 (VAR_DECL_CHECK (NODE))
/* Nonzero if this decl is always used by reference; i.e., an INDIRECT_REF
is needed to access the object. */
#define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE)
......
gcc/ada/decl.c
......@@ -176,8 +176,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
: LONG_LONG_TYPE_SIZE);
tree gnu_size = 0;
bool imported_p
= ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)))
|| From_With_Type (gnat_entity));
= (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
unsigned int align = 0;
/* Since a use of an Itype is a definition, process it as such if it
......@@ -424,6 +423,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
break;
}
else if (Present (CR_Discriminant (gnat_entity))
&& type_annotate_only)
{
gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
gnu_expr, definition);
saved = 1;
break;
}
/* If the enclosing record has explicit stored discriminants,
then it is an untagged record. If the Corresponding_Discriminant
is not empty then this must be a renamed discriminant and its
......@@ -815,21 +823,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
object, we just make a "bare" pointer, and the renamed
entity is always accessed indirectly through it. */
{
bool expr_has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
inner_const_flag = TREE_READONLY (gnu_expr);
const_flag = true;
gnu_type = build_reference_type (gnu_type);
/* If a previous attempt at unrestricted stabilization
failed, there is no point trying again and we can reuse
the result without attaching it to the pointer. */
the result without attaching it to the pointer. In this
case it will only be used as the initializing expression
of the pointer and thus needs no special treatment with
regard to multiple evaluations. */
if (maybe_stable_expr)
;
/* Otherwise, try to stabilize now, restricting to
lvalues only, and attach the expression to the pointer
if the stabilization succeeds.
/* Otherwise, try to stabilize now, restricting to lvalues
only, and attach the expression to the pointer if the
stabilization succeeds.
Note that this might introduce SAVE_EXPRs and we don't
check whether we're at the global level or not. This is
......@@ -852,21 +861,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (stabilized)
renamed_obj = maybe_stable_expr;
/* Attaching is actually performed downstream, as soon
as we have a DECL for the pointer we make. */
as we have a VAR_DECL for the pointer we make. */
}
gnu_expr
= build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
/* If the initial expression has side effects, we might
still have an unstabilized version at this point (for
instance if it involves a function call). Wrap the
result into a SAVE_EXPR now, in case it happens to be
referenced several times. */
if (expr_has_side_effects && ! stabilized)
gnu_expr = save_expr (gnu_expr);
gnu_size = NULL_TREE;
used_by_ref = true;
}
......@@ -930,7 +932,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* Ignore the size. It's either meaningless or was handled
above. */
gnu_size = NULL_TREE;
gnu_type = build_reference_type (gnu_type);
/* The address expression contains a conversion from pointer type
to the system__address integer type, which means the address
of the underlying object escapes. We therefore have no other
choice than forcing the type of the object being defined to
alias everything in order to make type-based alias analysis
aware that it will dereference the escaped address.
??? This uncovers problems in ACATS at -O2 with the volatility
of the original type: it may not be correctly propagated, thus
causing PRE to enter an infinite loop creating value numbers
out of volatile expressions. Disable it for now. */
gnu_type
= build_reference_type_for_mode (gnu_type, ptr_mode, false);
gnu_address = convert (gnu_type, gnu_address);
used_by_ref = true;
const_flag = !Is_Public (gnat_entity);
......@@ -959,7 +972,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| (Is_Imported (gnat_entity)
&& Has_Stdcall_Convention (gnat_entity)))
{
gnu_type = build_reference_type (gnu_type);
/* See the definition case above for the rationale. */
gnu_type
= build_reference_type_for_mode (gnu_type, ptr_mode, false);
gnu_size = NULL_TREE;
gnu_expr = NULL_TREE;
......@@ -1134,17 +1149,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
{
SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
DECL_RENAMING_GLOBAL_P (gnu_decl) = global_bindings_p ();
if (global_bindings_p ())
{
DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
record_global_renaming_pointer (gnu_decl);
}
}
/* If we have an address clause and we've made this indirect, it's
not enough to merely mark the type as volatile since volatile
references only conflict with other volatile references while this
reference must conflict with all other references. So ensure that
the dereferenced value has alias set 0. */
if (Present (Address_Clause (gnat_entity)) && used_by_ref)
DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
if (definition && DECL_SIZE (gnu_decl)
&& get_block_jmpbuf_decl ()
&& (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
......@@ -1169,9 +1180,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| Is_Aliased (Etype (gnat_entity))))
{
tree gnu_corr_var
= create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, false, Is_Public (gnat_entity),
false, static_p, NULL, gnat_entity);
= create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, true, Is_Public (gnat_entity),
false, static_p, NULL, gnat_entity);
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
}
......@@ -1220,6 +1231,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (No (First_Literal (gnat_entity)))
{
gnu_type = make_unsigned_type (esize);
TYPE_NAME (gnu_type) = gnu_entity_id;
/* Set the TYPE_STRING_FLAG for Ada Character and
Wide_Character types. This is needed by the dwarf-2 debug writer to
distinguish between unsigned integer types and character types. */
TYPE_STRING_FLAG (gnu_type) = 1;
break;
}
......@@ -1734,18 +1751,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
tem = build_array_type (tem, gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
/* If the type below this an multi-array type, then this
does not not have aliased components.
??? Otherwise, for now, we say that any component of aggregate
type is addressable because the front end may take 'Reference
of it. But we have to make it addressable if it must be passed
by reference or it that is the default. */
TYPE_NONALIASED_COMPONENT (tem)
= ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (tem))) ? 1
: (!Has_Aliased_Components (gnat_entity)
&& !AGGREGATE_TYPE_P (TREE_TYPE (tem))));
/* If the type below this is a multi-array type, then this
does not have aliased components. But we have to make
them addressable if it must be passed by reference or
if that is the default. */
if ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (tem)))
|| (!Has_Aliased_Components (gnat_entity)
&& !must_pass_by_ref (TREE_TYPE (tem))
&& !default_pass_by_ref (TREE_TYPE (tem))))
TYPE_NONALIASED_COMPONENT (tem) = 1;
}
/* If an alignment is specified, use it if valid. But ignore it for
......@@ -1957,13 +1972,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if ((TREE_CODE (gnu_min) == INTEGER_CST
&& !TREE_OVERFLOW (gnu_min)
&& !operand_equal_p (gnu_min, gnu_base_base_min, 0))
|| !CONTAINS_PLACEHOLDER_P (gnu_min))
|| !CONTAINS_PLACEHOLDER_P (gnu_min)
|| !(TREE_CODE (gnu_base_min) == INTEGER_CST
&& !TREE_OVERFLOW (gnu_base_min)))
gnu_base_min = gnu_min;
if ((TREE_CODE (gnu_max) == INTEGER_CST
&& !TREE_OVERFLOW (gnu_max)
&& !operand_equal_p (gnu_max, gnu_base_base_max, 0))
|| !CONTAINS_PLACEHOLDER_P (gnu_max))
|| !CONTAINS_PLACEHOLDER_P (gnu_max)
|| !(TREE_CODE (gnu_base_max) == INTEGER_CST
&& !TREE_OVERFLOW (gnu_base_max)))
gnu_base_max = gnu_max;
if ((TREE_CODE (gnu_base_min) == INTEGER_CST
......@@ -2054,18 +2073,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
/* If the type below this an multi-array type, then this
does not not have aliased components.
??? Otherwise, for now, we say that any component of aggregate
type is addressable because the front end may take 'Reference
of it. But we have to make it addressable if it must be passed
by reference or it that is the default. */
TYPE_NONALIASED_COMPONENT (gnu_type)
= ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) ? 1
: (!Has_Aliased_Components (gnat_entity)
&& !AGGREGATE_TYPE_P (TREE_TYPE (gnu_type))));
/* If the type below this is a multi-array type, then this
does not have aliased components. But we have to make
them addressable if it must be passed by reference or
if that is the default. */
if ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
|| (!Has_Aliased_Components (gnat_entity)
&& !must_pass_by_ref (TREE_TYPE (gnu_type))
&& !default_pass_by_ref (TREE_TYPE (gnu_type))))
TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
}
/* If we are at file level and this is a multi-dimensional array, we
......@@ -2381,27 +2399,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
/* Make a node for the record. If we are not defining the record,
suppress expanding incomplete types. We use the same RECORD_TYPE
as for a dummy type and reset TYPE_DUMMY_P to show it's no longer
a dummy.
It is very tempting to delay resetting this bit until we are done
with completing the type, e.g. to let possible intermediate
elaboration of access types designating the record know it is not
complete and arrange for update_pointer_to to fix things up later.
It would be wrong, however, because dummy types are expected only
to be created for Ada incomplete or private types, which is not
what we have here. Doing so would make other parts of gigi think
we are dealing with a really incomplete or private type, and have
nasty side effects, typically on the generation of the associated
debugging information. */
gnu_type = make_dummy_type (gnat_entity);
TYPE_DUMMY_P (gnu_type) = 0;
if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p)
DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0;
suppress expanding incomplete types. */
gnu_type = make_node (tree_code_for_record_type (gnat_entity));
TYPE_NAME (gnu_type) = gnu_entity_id;
/* ??? We should have create_type_decl like in the E_Record_Subtype
case below. Unfortunately this would cause GNU_TYPE to be marked
as visited, thus precluding the subtrees of the type that will be
built below from being marked as visited when the real TYPE_DECL
is eventually created. A solution could be to devise a special
version of the function under the name create_type_stub_decl. */
TYPE_STUB_DECL (gnu_type)
= build_decl (TYPE_DECL, NULL_TREE, gnu_type);
TYPE_ALIGN (gnu_type) = 0;
TYPE_PACKED (gnu_type) = packed || has_rep;
......@@ -2926,10 +2934,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
case E_General_Access_Type:
{
Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
/* Get the "full view" of this entity. If this is an incomplete
entity from a limited with, treat its non-limited view as the
full view. Otherwise, if this is an incomplete or private
type, use the full view. */
Entity_Id gnat_desig_full
= ((IN (Ekind (Etype (gnat_desig_type)),
Incomplete_Or_Private_Kind))
? Full_View (gnat_desig_type) : 0);
= (IN (Ekind (gnat_desig_type), Incomplete_Kind)
&& From_With_Type (gnat_desig_type))
? Non_Limited_View (gnat_desig_type)
: IN (Ekind (gnat_desig_type), Incomplete_Or_Private_Kind)
? Full_View (gnat_desig_type)
: Empty;
/* We want to know if we'll be seeing the freeze node for any
incomplete type we may be pointing to. */
bool in_main_unit
......@@ -3008,6 +3023,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& defer_incomplete_level
&& !present_gnu_tree (gnat_desig_type)
&& Is_Array_Type (gnat_desig_type)
&& ! Is_Constrained (gnat_desig_type))
|| (in_main_unit && From_With_Type (gnat_entity)
&& (Present (gnat_desig_full)
? Present (Freeze_Node (gnat_desig_full))
: Present (Freeze_Node (gnat_desig_type)))
&& Is_Array_Type (gnat_desig_type)
&& !Is_Constrained (gnat_desig_type)))
{
tree gnu_old
......@@ -3089,6 +3110,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_desig_type = make_dummy_type (gnat_desig_type);
made_dummy = true;
}
/* If this is a reference from a limited_with type back to our
main unit and there's a Freeze_Node for it, either we have
already processed the declaration and made the dummy type,
in which case we just reuse the latter, or we have not yet,
in which case we make the dummy type and it will be reused
when the declaration is processed. In both cases, the pointer
eventually created below will be automatically adjusted when
the Freeze_Node is processed. Note that the unconstrained
array case is handled above. */
else if (in_main_unit && From_With_Type (gnat_entity)
&& (Present (gnat_desig_full)
? Present (Freeze_Node (gnat_desig_full))
: Present (Freeze_Node (gnat_desig_type))))
{
gnu_desig_type = make_dummy_type (gnat_desig_type);
made_dummy = true;
}
else if (gnat_desig_type == gnat_entity)
{
gnu_type
......@@ -3097,6 +3137,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
No_Strict_Aliasing (gnat_entity));
TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
}
else
gnu_desig_type = gnat_to_gnu_type (gnat_desig_type);
......@@ -3210,8 +3251,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (type_annotate_only && No (Equivalent_Type (gnat_entity)))
gnu_type = build_pointer_type (void_type_node);
else
/* The runtime representation is the equivalent type. */
gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
{
/* The runtime representation is the equivalent type. */
gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
maybe_present = 1;
}
if (Is_Itype (Directly_Designated_Type (gnat_entity))
&& !present_gnu_tree (Directly_Designated_Type (gnat_entity))
......@@ -3373,7 +3417,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_expr, 0);
/* Elaborate any Itypes in the parameters of this entity. */
for (gnat_temp = First_Formal (gnat_entity);
for (gnat_temp = First_Formal_With_Extras (gnat_entity);
Present (gnat_temp);
gnat_temp = Next_Formal_With_Extras (gnat_temp))
if (Is_Itype (Etype (gnat_temp)))
......@@ -3413,8 +3457,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
else if (kind == E_Function
&& Mechanism (gnat_entity) == By_Reference)
{
gnu_return_type = copy_type (gnu_return_type);
TREE_ADDRESSABLE (gnu_return_type) = 1;
/* We expect this bit to be reset by gigi shortly, so can avoid a
type node copy here. This actually also prevents troubles with
the generation of debug information for the function, because
we might have issued such info for this type already, and would
be attaching a distinct type node to the function if we made a
copy here. */
}
/* If we are supposed to return an unconstrained array,
......@@ -3479,7 +3529,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
each. While doing this, build a copy-out structure if
we need one. */
for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
{
......@@ -3858,71 +3908,76 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
break;
case E_Incomplete_Type:
case E_Incomplete_Subtype:
case E_Private_Type:
case E_Limited_Private_Type:
case E_Record_Type_With_Private:
case E_Private_Subtype:
case E_Limited_Private_Type:
case E_Limited_Private_Subtype:
case E_Record_Type_With_Private:
case E_Record_Subtype_With_Private:
/* If this type does not have a full view in the unit we are
compiling, then just get the type from its Etype. */
if (No (Full_View (gnat_entity)))
{
/* If this is an incomplete type with no full view, it must be
either a limited view brought in by a limited_with clause, in
which case we use the non-limited view, or a Taft Amendement
type, in which case we just return a dummy type. */
if (kind == E_Incomplete_Type)
{
if (From_With_Type (gnat_entity)
&& Present (Non_Limited_View (gnat_entity)))
gnu_decl = gnat_to_gnu_entity (Non_Limited_View (gnat_entity),
{
/* Get the "full view" of this entity. If this is an incomplete
entity from a limited with, treat its non-limited view as the
full view. Otherwise, use either the full view or the underlying
full view, whichever is present. This is used in all the tests
below. */
Entity_Id full_view
= (IN (Ekind (gnat_entity), Incomplete_Kind)
&& From_With_Type (gnat_entity))
? Non_Limited_View (gnat_entity)
: Present (Full_View (gnat_entity))
? Full_View (gnat_entity)
: Underlying_Full_View (gnat_entity);
/* If this is an incomplete type with no full view, it must be a Taft
Amendment type, in which case we return a dummy type. Otherwise,
just get the type from its Etype. */
if (No (full_view))
{
if (kind == E_Incomplete_Type)
gnu_type = make_dummy_type (gnat_entity);
else
{
gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
NULL_TREE, 0);
else
gnu_type = make_dummy_type (gnat_entity);
}
else if (Present (Underlying_Full_View (gnat_entity)))
gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
NULL_TREE, 0);
else
{
gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
NULL_TREE, 0);
maybe_present = true;
}
break;
}
maybe_present = true;
}
break;
}
/* Otherwise, if we are not defining the type now, get the
type from the full view. But always get the type from the full
view for define on use types, since otherwise we won't see them! */
/* If we already made a type for the full view, reuse it. */
else if (present_gnu_tree (full_view))
{
gnu_decl = get_gnu_tree (full_view);
break;
}
else if (!definition
|| (Is_Itype (Full_View (gnat_entity))
/* Otherwise, if we are not defining the type now, get the type
from the full view. But always get the type from the full view
for define on use types, since otherwise we won't see them! */
else if (!definition
|| (Is_Itype (full_view)
&& No (Freeze_Node (gnat_entity)))
|| (Is_Itype (gnat_entity)
&& No (Freeze_Node (Full_View (gnat_entity)))))
{
gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
NULL_TREE, 0);
maybe_present = true;
break;
}
|| (Is_Itype (gnat_entity)
&& No (Freeze_Node (full_view))))
{
gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
maybe_present = true;
break;
}
/* For incomplete types, make a dummy type entry which will be
replaced later. */
gnu_type = make_dummy_type (gnat_entity);
/* For incomplete types, make a dummy type entry which will be
replaced later. */
gnu_type = make_dummy_type (gnat_entity);
/* Save this type as the full declaration's type so we can do any needed
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, gnat_entity);
save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
break;
/* Save this type as the full declaration's type so we can do any
needed 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, gnat_entity);
save_gnu_tree (full_view, gnu_decl, 0);
break;
}
/* Simple class_wide types are always viewed as their root_type
by Gigi unless an Equivalent_Type is specified. */
......@@ -4521,88 +4576,6 @@ substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
return gnu_list;
}
/* For the following two functions: for each GNAT entity, the GCC
tree node used as a dummy for that entity, if any. */
static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table;
/* Initialize the above table. */
void
init_dummy_type (void)
{
Node_Id gnat_node;
dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree));
for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
dummy_node_table[gnat_node] = NULL_TREE;
dummy_node_table -= First_Node_Id;
}
/* Make a dummy type corresponding to GNAT_TYPE. */
tree
make_dummy_type (Entity_Id gnat_type)
{
Entity_Id gnat_underlying;
tree gnu_type;
enum tree_code code;
/* Find a full type for GNAT_TYPE, taking into account any class wide
types. */
if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
gnat_type = Equivalent_Type (gnat_type);
else if (Ekind (gnat_type) == E_Class_Wide_Type)
gnat_type = Root_Type (gnat_type);
for (gnat_underlying = gnat_type;
(IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_underlying)));
gnat_underlying = Full_View (gnat_underlying))
;
/* If it there already a dummy type, use that one. Else make one. */
if (dummy_node_table[gnat_underlying])
return dummy_node_table[gnat_underlying];
/* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
it an ENUMERAL_TYPE. */
if (Is_Record_Type (gnat_underlying))
{
Node_Id component_list
= Component_List (Type_Definition
(Declaration_Node
(Implementation_Base_Type (gnat_underlying))));
Node_Id component;
/* Make this a UNION_TYPE unless it's either not an Unchecked_Union or
we have a non-discriminant field outside a variant. In either case,
it's a RECORD_TYPE. */
code = UNION_TYPE;
if (!Is_Unchecked_Union (gnat_underlying))
code = RECORD_TYPE;
else
for (component = First_Non_Pragma (Component_Items (component_list));
Present (component); component = Next_Non_Pragma (component))
if (Ekind (Defining_Entity (component)) == E_Component)
code = RECORD_TYPE;
}
else
code = ENUMERAL_TYPE;
gnu_type = make_node (code);
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) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
dummy_node_table[gnat_underlying] = gnu_type;
return gnu_type;
}
/* Return true if the size represented by GNU_SIZE can be handled by an
allocation. If STATIC_P is true, consider only what can be done with a
static allocation. */
......@@ -4830,7 +4803,8 @@ elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
&& !(TREE_CODE (gnu_inner_expr) == VAR_DECL
&& TREE_READONLY (gnu_inner_expr))
&& (TREE_READONLY (gnu_inner_expr)
|| DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
&& !CONTAINS_PLACEHOLDER_P (gnu_expr));
/* If this is a static expression or contains a discriminant, we don't
......@@ -6875,5 +6849,3 @@ concat_id_with_name (tree gnu_id, const char *suffix)
strcpy (Name_Buffer + len, suffix);
return get_identifier (Name_Buffer);
}
#include "gt-ada-decl.h"
gcc/ada/gigi.h
......@@ -380,9 +380,6 @@ enum standard_datatypes
extern GTY(()) tree gnat_std_decls[(int) ADT_LAST];
extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
extern GTY(()) tree static_ctors;
extern GTY(()) tree static_dtors;
#define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type]
#define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl]
#define except_type_node gnat_std_decls[(int) ADT_except_type]
......@@ -448,6 +445,9 @@ extern tree gnat_type_for_size (unsigned precision, int unsignedp);
an unsigned type; otherwise a signed type is returned. */
extern tree gnat_type_for_mode (enum machine_mode mode, int unsignedp);
/* Emit debug info for all global variable declarations. */
extern void gnat_write_global_declarations (void);
/* Return the unsigned version of a TYPE_NODE, a scalar type. */
extern tree gnat_unsigned_type (tree type_node);
......@@ -533,10 +533,11 @@ extern tree create_type_decl (tree type_name, tree type,
bool artificial_p, bool debug_info_p,
Node_Id gnat_node);
/* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
ASM_NAME is its assembler name (if provided). TYPE is
its data type (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an
optional initial expression; NULL_TREE if none.
/* Returns a GCC VAR_DECL or CONST_DECL node.
VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
(if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is
the GCC tree for an optional initial expression; NULL_TREE if none.
CONST_FLAG is true if this variable is constant.
......@@ -556,9 +557,22 @@ extern tree create_var_decl (tree var_name, tree asm_name, tree type,
bool static_flag,
struct attrib *attr_list, Node_Id gnat_node);
/* Similar to create_var_decl, forcing the creation of a VAR_DECL node. */
extern tree create_true_var_decl (tree var_name, tree asm_name, tree type,
tree var_init, bool const_flag,
bool public_flag, bool extern_flag,
bool static_flag,
struct attrib *attr_list, Node_Id gnat_node);
/* Given a DECL and ATTR_LIST, apply the listed attributes. */
extern void process_attributes (tree decl, struct attrib *attr_list);
/* Record a global renaming pointer. */
void record_global_renaming_pointer (tree);
/* Invalidate the global renaming pointers. */
void invalidate_global_renaming_pointers (void);
/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
this field is in a record type with a "pragma pack". If SIZE is nonzero
......@@ -656,6 +670,10 @@ extern tree maybe_unconstrained_array (tree exp);
If NOTRUNC_P is true, truncation operations should be suppressed. */
extern tree unchecked_convert (tree type, tree expr, bool notrunc_p);
/* Return the appropriate GCC tree code for the specified GNAT type,
the latter being a record type as predicated by Is_Record_Type. */
extern enum tree_code tree_code_for_record_type (Entity_Id);
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
......
gcc/ada/misc.c
......@@ -127,6 +127,8 @@ static tree gnat_type_max_size (tree);
#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v
#undef LANG_HOOKS_PUSHDECL
#define LANG_HOOKS_PUSHDECL lhd_return_tree
#undef LANG_HOOKS_WRITE_GLOBALS
#define LANG_HOOKS_WRITE_GLOBALS gnat_write_global_declarations
#undef LANG_HOOKS_FINISH_INCOMPLETE_DECL
#define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
#undef LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS
......@@ -233,23 +235,22 @@ gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
{
int seh[2];
/* call the target specific initializations */
/* Call the target specific initializations. */
__gnat_initialize (NULL);
/* ??? call the SEH initialization routine, this is to workaround a
bootstrap path problem. The call below should be removed at some point and
the seh pointer passed to __gnat_initialize() above. */
/* ??? Call the SEH initialization routine. This is to workaround
a bootstrap path problem. The call below should be removed at some
point and the SEH pointer passed to __gnat_initialize() above. */
__gnat_install_SEH_handler((void *)seh);
/* Call the front-end elaboration procedures */
/* Call the front-end elaboration procedures. */
adainit ();
/* Call the front end */
/* Call the front end. */
_ada_gnat1drv ();
/* We always have a single compilation unit in Ada. */
cgraph_finalize_compilation_unit ();
cgraph_optimize ();
}
/* Decode all the language specific options that cannot be decoded by GCC.
......@@ -365,6 +366,9 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
if (flag_inline_functions)
flag_inline_trees = 2;
/* The structural alias analysis machinery essentially assumes that
everything is addressable (modulo bit-fields) by disregarding
the TYPE_NONALIASED_COMPONENT and DECL_NONADDRESSABLE_P macros. */
flag_tree_salias = 0;
return false;
......@@ -771,7 +775,7 @@ gnat_type_max_size (tree gnu_type)
&& TYPE_ADA_SIZE (gnu_type))
{
tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
/* If we have succeded in finding a constant, round it up to the
type's alignment and return the result in byte units. */
......
gcc/ada/trans.c
......@@ -149,7 +149,7 @@ 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 unshare_save_expr (tree *, int *, void *);
static tree end_stmt_group (void);
static void add_stmt_list (List_Id);
static tree build_stmt_group (List_Id, bool);
......@@ -171,7 +171,6 @@ static tree pos_to_constructor (Node_Id, tree, Entity_Id);
static tree maybe_implicit_deref (tree);
static tree gnat_stabilize_reference_1 (tree, bool);
static void annotate_with_node (tree, Node_Id);
static void build_global_cdtor (int, tree *);
/* This is the main program of the back-end. It sets up all the table
......@@ -252,8 +251,15 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
tree gnu_stmts;
/* Mark everything we have as not visited. */
walk_tree_without_duplicates (&gnu_body, mark_unvisited, NULL);
/* Unshare SAVE_EXPRs between subprograms. These are not unshared by
the gimplifier for obvious reasons, but it turns out that we need to
unshare them for the global level because of SAVE_EXPRs made around
checks for global objects and around allocators for global objects
of variable size, in order to prevent node sharing in the underlying
expression. Note that this implicitly assumes that the SAVE_EXPR
nodes themselves are not shared between subprograms, which would be
an upstream bug for which we would not change the outcome. */
walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL);
/* Set the current function to be the elaboration procedure and gimplify
what we have. */
......@@ -382,10 +388,17 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
handler, only if it is referenced in the handler and declared in an
enclosing block, but we have no way of testing that right now.
??? Also, for now all we can do is make it volatile. But we only
do this for SJLJ. */
??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
     here, but it can now be removed by the Tree aliasing machinery if the
     address of the variable is never taken.  All we can do is to make the
     variable volatile, which might incur the generation of temporaries just
to access the memory in some circumstances.  This can be avoided for
     variables of non-constant size because they are automatically allocated
     to memory. There might be no way of allocating a proper temporary for
them in any case. We only do this for SJLJ though. */
if (TREE_VALUE (gnu_except_ptr_stack)
&& TREE_CODE (gnu_result) == VAR_DECL)
&& TREE_CODE (gnu_result) == VAR_DECL
&& TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST)
TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
/* Some objects (such as parameters passed by reference, globals of
......@@ -452,18 +465,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
== Attr_Unchecked_Access)
|| (Get_Attribute_Id (Attribute_Name (gnat_temp))
== Attr_Unrestricted_Access)))))
{
gnu_result = DECL_INITIAL (gnu_result);
/* ??? The mark/unmark mechanism implemented in Gigi to prevent tree
sharing between global level and subprogram level doesn't apply
to elaboration routines. As a result, the DECL_INITIAL tree may
be shared between the static initializer of a global object and
the elaboration routine, thus wreaking havoc if a local temporary
is created in place during gimplification of the latter and the
former is emitted afterwards. Manually unshare for now. */
if (TREE_VISITED (gnu_result))
gnu_result = unshare_expr (gnu_result);
}
gnu_result = DECL_INITIAL (gnu_result);
}
*gnu_result_type_p = gnu_result_type;
......@@ -795,10 +797,9 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
prefix_unused = true;
if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
gnu_result = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)));
else
gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF
? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))
: TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT);
break;
case Attr_First:
......@@ -1145,6 +1146,7 @@ Case_Statement_to_gnu (Node_Id gnat_node)
gnat_when = Next_Non_Pragma (gnat_when))
{
Node_Id gnat_choice;
int choices_added = 0;
/* First compile all the different case choices for the current WHEN
alternative. */
......@@ -1195,18 +1197,33 @@ Case_Statement_to_gnu (Node_Id gnat_node)
gcc_unreachable ();
}
add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
gnu_low, gnu_high,
create_artificial_label ()),
gnat_choice);
/* If the case value is a subtype that raises Constraint_Error at
run-time because of a wrong bound, then gnu_low or gnu_high
is not transtaleted into an INTEGER_CST. In such a case, we need
to ensure that the when statement is not added in the tree,
otherwise it will crash the gimplifier. */
if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
&& (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
{
add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
gnu_low, gnu_high,
create_artificial_label ()),
gnat_choice);
choices_added++;
}
}
/* Push a binding level here in case variables are declared since we want
them to be local to this set of statements instead of the block
containing the Case statement. */
add_stmt (build_stmt_group (Statements (gnat_when), true));
add_stmt (build1 (GOTO_EXPR, void_type_node,
TREE_VALUE (gnu_switch_label_stack)));
them to be local to this set of statements instead of the block
containing the Case statement. */
if (choices_added > 0)
{
add_stmt (build_stmt_group (Statements (gnat_when), true));
add_stmt (build1 (GOTO_EXPR, void_type_node,
TREE_VALUE (gnu_switch_label_stack)));
}
}
/* Now emit a definition of the label all the cases branched to. */
......@@ -1484,7 +1501,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty
entry as well. We can match up the entries because TYPE_CI_CO_LIST is in
the order of the parameters. */
for (gnat_param = First_Formal (gnat_subprog_id);
for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param))
if (!present_gnu_tree (gnat_param))
......@@ -1570,7 +1587,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
/* Disconnect the trees for parameters that we made variables for from the
GNAT entities since these are unusable after we end the function. */
for (gnat_param = First_Formal (gnat_subprog_id);
for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param))
if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
......@@ -1687,12 +1704,12 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
type the access type is pointing to. Otherwise, get the formals from
entity being called. */
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
gnat_formal = First_Formal (Etype (Name (gnat_node)));
gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
/* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
gnat_formal = 0;
else
gnat_formal = First_Formal (Entity (Name (gnat_node)));
gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
/* Create the list of the actual parameters as GCC expects it, namely a chain
of TREE_LIST nodes in which the TREE_VALUE field of each node is a
......@@ -1741,6 +1758,11 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
tree gnu_copy = gnu_name;
tree gnu_temp;
/* If the type is by_reference, a copy is not allowed. */
if (Is_By_Reference_Type (Etype (gnat_formal)))
post_error
("misaligned & cannot be passed by reference", gnat_actual);
/* For users of Starlet we issue a warning because the
interface apparently assumes that by-ref parameters
outlive the procedure invocation. The code still
......@@ -1749,7 +1771,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
would allocate temporaries at will because of the
misalignment if we did not do so here. */
if (Is_Valued_Procedure (Entity (Name (gnat_node))))
else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
{
post_error
("?possible violation of implicit assumption",
......@@ -1889,6 +1911,13 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
&& !addressable_p (gnu_actual))
gnu_actual = TREE_OPERAND (gnu_actual, 0);
/* For In parameters, gnu_actual might still not be addressable at
this point and we need the creation of a temporary copy since
this is to be passed by ref. Resorting to save_expr to force a
SAVE_EXPR temporary creation here is not guaranteed to work
because the actual might be invariant or readonly without side
effects, so we let the gimplifier process this case. */
/* The symmetry of the paths to the type of an entity is broken here
since arguments don't know that they will be passed by ref. */
gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
......@@ -2026,9 +2055,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
}
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
gnat_formal = First_Formal (Etype (Name (gnat_node)));
gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
else
gnat_formal = First_Formal (Entity (Name (gnat_node)));
gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
for (gnat_actual = First_Actual (gnat_node);
Present (gnat_actual);
......@@ -2053,8 +2082,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
: build_component_ref (gnu_subprog_call, NULL_TREE,
TREE_PURPOSE (scalar_return_list),
false);
bool unchecked_conversion = (Nkind (gnat_actual)
== N_Unchecked_Type_Conversion);
/* If the actual is a conversion, get the inner expression, which
will be the real destination, and convert the result to the
type of the actual parameter. */
......@@ -2068,16 +2096,33 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
(TREE_TYPE (gnu_result))),
gnu_result);
/* If the result is a type conversion, do it. */
/* If the actual is a type conversion, the real target object is
denoted by the inner Expression and we need to convert the
result to the associated type.
We also need to convert our gnu assignment target to this type
if the corresponding gnu_name was constructed from the GNAT
conversion node and not from the inner Expression. */
if (Nkind (gnat_actual) == N_Type_Conversion)
gnu_result
= convert_with_check
(Etype (Expression (gnat_actual)), gnu_result,
Do_Overflow_Check (gnat_actual),
Do_Range_Check (Expression (gnat_actual)),
Float_Truncate (gnat_actual));
{
gnu_result
= convert_with_check
(Etype (Expression (gnat_actual)), gnu_result,
Do_Overflow_Check (gnat_actual),
Do_Range_Check (Expression (gnat_actual)),
Float_Truncate (gnat_actual));
if (!Is_Composite_Type
(Underlying_Type (Etype (gnat_formal))))
gnu_actual
= convert (TREE_TYPE (gnu_result), gnu_actual);
}
else if (unchecked_conversion)
/* Unchecked conversions as actuals for out parameters are not
allowed in user code because they are not variables, but do
occur in front-end expansions. The associated gnu_name is
always obtained from the inner expression in such cases. */
else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
gnu_result,
No_Truncation (gnat_actual));
......@@ -2152,11 +2197,6 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
gnat_pushlevel ();
}
/* If we are to call a function when exiting this block add a cleanup
to the binding level we made above. */
if (at_end)
add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))));
/* If using setjmp_longjmp, make the variables for the setjmp buffer and save
area for address of previous buffer. Do this first since we need to have
the setjmp buf known for any decls in this block. */
......@@ -2183,6 +2223,12 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
}
/* If we are to call a function when exiting this block, add a cleanup
to the binding level we made above. Note that add_cleanup is FIFO
so we must register this cleanup after the EH cleanup just above. */
if (at_end)
add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))));
/* Now build the tree for the declarations and statements inside this block.
If this is SJLJ, set our jmp_buf as the current buffer. */
start_stmt_group ();
......@@ -2525,7 +2571,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
process_inlined_subprograms (gnat_node);
if (type_annotate_only)
if (type_annotate_only && gnat_node == Cunit (Main_Unit))
{
elaborate_all_entities (gnat_node);
......@@ -2558,14 +2604,10 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
we did or not. */
pop_stack (&gnu_elab_proc_stack);
/* Generate functions to call static constructors and destructors
for targets that do not support .ctors/.dtors sections. These
functions have magic names which are detected by collect2. */
if (static_ctors)
build_global_cdtor ('I', &static_ctors);
if (static_dtors)
build_global_cdtor ('D', &static_dtors);
/* Invalidate the global renaming pointers. This is necessary because
stabilization of the renamed entities may create SAVE_EXPRs which
have been tied to a specific elaboration routine just above. */
invalidate_global_renaming_pointers ();
}
/* This function is the driver of the GNAT to GCC tree transformation
......@@ -3330,6 +3372,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_And_Then: case N_Or_Else:
{
enum tree_code code = gnu_codes[Nkind (gnat_node)];
bool ignore_lhs_overflow = false;
tree gnu_type;
gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
......@@ -3378,17 +3421,32 @@ gnat_to_gnu (Node_Id gnat_node)
}
/* For right shifts, the type says what kind of shift to do,
so we may need to choose a different type. */
so we may need to choose a different type. In this case,
we have to ignore integer overflow lest it propagates all
the way down and causes a CE to be explicitly raised. */
if (Nkind (gnat_node) == N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type))
gnu_type = gnat_unsigned_type (gnu_type);
{
gnu_type = gnat_unsigned_type (gnu_type);
ignore_lhs_overflow = true;
}
else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
&& TYPE_UNSIGNED (gnu_type))
gnu_type = gnat_signed_type (gnu_type);
{
gnu_type = gnat_signed_type (gnu_type);
ignore_lhs_overflow = true;
}
if (gnu_type != gnu_result_type)
{
tree gnu_old_lhs = gnu_lhs;
gnu_lhs = convert (gnu_type, gnu_lhs);
if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
{
TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
TREE_CONSTANT_OVERFLOW (gnu_lhs)
= TREE_CONSTANT_OVERFLOW (gnu_old_lhs);
}
gnu_rhs = convert (gnu_type, gnu_rhs);
}
......@@ -3773,16 +3831,31 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Abstract_Subprogram_Declaration:
/* This subprogram doesn't exist for code generation purposes, but we
have to elaborate the types of any parameters, unless they are
imported types (nothing to generate in this case). */
have to elaborate the types of any parameters and result, unless
they are imported types (nothing to generate in this case). */
/* Process the parameter types first. */
for (gnat_temp
= First_Formal (Defining_Entity (Specification (gnat_node)));
= First_Formal_With_Extras
(Defining_Entity (Specification (gnat_node)));
Present (gnat_temp);
gnat_temp = Next_Formal_With_Extras (gnat_temp))
if (Is_Itype (Etype (gnat_temp))
&& !From_With_Type (Etype (gnat_temp)))
gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
/* Then the result type, set to Standard_Void_Type for procedures. */
{
Entity_Id gnat_temp_type
= Etype (Defining_Entity (Specification (gnat_node)));
if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
}
gnu_result = alloc_stmt_list ();
break;
......@@ -3965,47 +4038,102 @@ gnat_to_gnu (Node_Id gnat_node)
if (!type_annotate_only)
{
tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
tree gnu_input_list = NULL_TREE, gnu_output_list = NULL_TREE;
tree gnu_clobber_list = NULL_TREE;
tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
tree gnu_clobbers = NULL_TREE, tail;
bool allows_mem, allows_reg, fake;
int ninputs, noutputs, i;
const char **oconstraints;
const char *constraint;
char *clobber;
/* First process inputs, then outputs, then clobbers. */
Setup_Asm_Inputs (gnat_node);
while (Present (gnat_temp = Asm_Input_Value ()))
/* First retrieve the 3 operand lists built by the front-end. */
Setup_Asm_Outputs (gnat_node);
while (Present (gnat_temp = Asm_Output_Variable ()))
{
tree gnu_value = gnat_to_gnu (gnat_temp);
tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
(Asm_Input_Constraint ()));
(Asm_Output_Constraint ()));
gnu_input_list
= tree_cons (gnu_constr, gnu_value, gnu_input_list);
Next_Asm_Input ();
gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
Next_Asm_Output ();
}
Setup_Asm_Outputs (gnat_node);
while (Present (gnat_temp = Asm_Output_Variable ()))
Setup_Asm_Inputs (gnat_node);
while (Present (gnat_temp = Asm_Input_Value ()))
{
tree gnu_value = gnat_to_gnu (gnat_temp);
tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
(Asm_Output_Constraint ()));
(Asm_Input_Constraint ()));
gnu_output_list
= tree_cons (gnu_constr, gnu_value, gnu_output_list);
Next_Asm_Output ();
gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
Next_Asm_Input ();
}
Clobber_Setup (gnat_node);
while ((clobber = Clobber_Get_Next ()))
gnu_clobber_list
gnu_clobbers
= tree_cons (NULL_TREE,
build_string (strlen (clobber) + 1, clobber),
gnu_clobber_list);
gnu_clobbers);
/* Then perform some standard checking and processing on the
operands. In particular, mark them addressable if needed. */
gnu_outputs = nreverse (gnu_outputs);
noutputs = list_length (gnu_outputs);
gnu_inputs = nreverse (gnu_inputs);
ninputs = list_length (gnu_inputs);
oconstraints
= (const char **) alloca (noutputs * sizeof (const char *));
for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
{
tree output = TREE_VALUE (tail);
constraint
= TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
oconstraints[i] = constraint;
if (parse_output_constraint (&constraint, i, ninputs, noutputs,
&allows_mem, &allows_reg, &fake))
{
/* If the operand is going to end up in memory,
mark it addressable. Note that we don't test
allows_mem like in the input case below; this
is modelled on the C front-end. */
if (!allows_reg
&& !gnat_mark_addressable (output))
output = error_mark_node;
}
else
output = error_mark_node;
TREE_VALUE (tail) = output;
}
for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
{
tree input = TREE_VALUE (tail);
constraint
= TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
if (parse_input_constraint (&constraint, i, ninputs, noutputs,
0, oconstraints,
&allows_mem, &allows_reg))
{
/* If the operand is going to end up in memory,
mark it addressable. */
if (!allows_reg && allows_mem
&& !gnat_mark_addressable (input))
input = error_mark_node;
}
else
input = error_mark_node;
TREE_VALUE (tail) = input;
}
gnu_input_list = nreverse (gnu_input_list);
gnu_output_list = nreverse (gnu_output_list);
gnu_result = build4 (ASM_EXPR, void_type_node,
gnu_template, gnu_output_list,
gnu_input_list, gnu_clobber_list);
gnu_template, gnu_outputs,
gnu_inputs, gnu_clobbers);
ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
}
else
......@@ -4372,12 +4500,6 @@ void
add_stmt (tree gnu_stmt)
{
append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
/* If we're at top level, show everything in here is in use in case
any of it is shared by a subprogram. */
if (global_bindings_p ())
walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
}
/* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
......@@ -4407,15 +4529,16 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
&& TREE_CODE (TREE_TYPE (gnu_decl)) == UNCONSTRAINED_ARRAY_TYPE))
return;
gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
/* If we are global, we don't want to actually output the DECL_EXPR for
this decl since we already have evaluated the expressions in the
sizes and positions as globals and doing it again would be wrong.
But we do have to mark everything as used. */
gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
if (!global_bindings_p ())
add_stmt_with_node (gnu_stmt, gnat_entity);
else
sizes and positions as globals and doing it again would be wrong. */
if (global_bindings_p ())
{
/* Mark everything as used to prevent node sharing with subprograms.
Note that walk_tree knows how to handle TYPE_DECL, but neither
VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
if (TREE_CODE (gnu_decl) == VAR_DECL
|| TREE_CODE (gnu_decl) == CONST_DECL)
......@@ -4425,6 +4548,8 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL);
}
}
else
add_stmt_with_node (gnu_stmt, gnat_entity);
/* If this is a DECL_EXPR for a variable with DECL_INITIAL set,
there are two cases we need to handle here. */
......@@ -4455,8 +4580,12 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
= build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_lhs, DECL_INITIAL (gnu_decl));
DECL_INITIAL (gnu_decl) = 0;
TREE_READONLY (gnu_decl) = 0;
DECL_INITIAL (gnu_decl) = NULL_TREE;
if (TREE_READONLY (gnu_decl))
{
TREE_READONLY (gnu_decl) = 0;
DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
}
annotate_with_locus (gnu_assign_stmt,
DECL_SOURCE_LOCATION (gnu_decl));
add_stmt (gnu_assign_stmt);
......@@ -4486,13 +4615,16 @@ mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
return NULL_TREE;
}
/* Likewise, but to mark as unvisited. */
/* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */
static tree
mark_unvisited (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
{
TREE_VISITED (*tp) = 0;
tree t = *tp;
if (TREE_CODE (t) == SAVE_EXPR)
TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0));
return NULL_TREE;
}
......@@ -4833,48 +4965,33 @@ gnat_gimplify_stmt (tree *stmt_p)
}
}
/* Force references to each of the entities in packages GNAT_NODE with's
so that the debugging information for all of them are identical
in all clients. Operate recursively on anything it with's, but check
that we aren't elaborating something more than once. */
/* The reason for this routine's existence is two-fold.
First, with some debugging formats, notably MDEBUG on SGI
IRIX, the linker will remove duplicate debugging information if two
clients have identical debugging information. With the normal scheme
of elaboration, this does not usually occur, since entities in with'ed
packages are elaborated on demand, and if clients have different usage
patterns, the normal case, then the order and selection of entities
will differ. In most cases however, it seems that linkers do not know
how to eliminate duplicate debugging information, even if it is
identical, so the use of this routine would increase the total amount
of debugging information in the final executable.
Second, this routine is called in type_annotate mode, to compute DDA
information for types in withed units, for ASIS use */
/* Force references to each of the entities in packages withed by GNAT_NODE.
Operate recursively but check that we aren't elaborating something more
than once.
This routine is exclusively called in type_annotate mode, to compute DDA
information for types in withed units, for ASIS use. */
static void
elaborate_all_entities (Node_Id gnat_node)
{
Entity_Id gnat_with_clause, gnat_entity;
/* Process each unit only once. As we trace the context of all relevant
/* Process each unit only once. As we trace the context of all relevant
units transitively, including generic bodies, we may encounter the
same generic unit repeatedly */
same generic unit repeatedly. */
if (!present_gnu_tree (gnat_node))
save_gnu_tree (gnat_node, integer_zero_node, true);
/* Save entities in all context units. A body may have an implicit_with
/* Save entities in all context units. A body may have an implicit_with
on its own spec, if the context includes a child unit, so don't save
the spec twice. */
for (gnat_with_clause = First (Context_Items (gnat_node));
Present (gnat_with_clause);
gnat_with_clause = Next (gnat_with_clause))
if (Nkind (gnat_with_clause) == N_With_Clause
&& !present_gnu_tree (Library_Unit (gnat_with_clause))
&& Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
&& Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
{
elaborate_all_entities (Library_Unit (gnat_with_clause));
......@@ -4897,23 +5014,23 @@ elaborate_all_entities (Node_Id gnat_node)
&& !IN (Ekind (gnat_entity), Generic_Unit_Kind))
gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
}
else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
{
Node_Id gnat_body
else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
{
Node_Id gnat_body
= Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
/* Retrieve compilation unit node of generic body. */
while (Present (gnat_body)
/* Retrieve compilation unit node of generic body. */
while (Present (gnat_body)
&& Nkind (gnat_body) != N_Compilation_Unit)
gnat_body = Parent (gnat_body);
/* If body is available, elaborate its context. */
if (Present (gnat_body))
elaborate_all_entities (gnat_body);
}
/* If body is available, elaborate its context. */
if (Present (gnat_body))
elaborate_all_entities (gnat_body);
}
}
if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
if (Nkind (Unit (gnat_node)) == N_Package_Body)
elaborate_all_entities (Library_Unit (gnat_node));
}
......@@ -4969,11 +5086,12 @@ process_freeze_entity (Node_Id gnat_node)
&& Ekind (gnat_entity) == E_Subprogram_Type)))
return;
/* If we have a non-dummy type old tree, we have nothing to do. Unless
this is the public view of a private type whose full view was not
delayed, this node was never delayed as it should have been.
Also allow this to happen for concurrent types since we may have
frozen both the Corresponding_Record_Type and this type. */
/* If we have a non-dummy type old tree, we have nothing to do, except
aborting if this is the public view of a private type whose full view was
not delayed, as this node was never delayed as it should have been. We
let this happen for concurrent types and their Corresponding_Record_Type,
however, because each might legitimately be elaborated before it's own
freeze node, e.g. while processing the other. */
if (gnu_old
&& !(TREE_CODE (gnu_old) == TYPE_DECL
&& TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
......@@ -4981,7 +5099,9 @@ process_freeze_entity (Node_Id gnat_node)
gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity))
&& No (Freeze_Node (Full_View (gnat_entity))))
|| Is_Concurrent_Type (gnat_entity));
|| Is_Concurrent_Type (gnat_entity)
|| (IN (Ekind (gnat_entity), Record_Kind)
&& Is_Concurrent_Record_Type (gnat_entity)));
return;
}
......@@ -5220,7 +5340,7 @@ emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
/* There's no good type to use here, so we might as well use
integer_type_node. Note that the form of the check is
(not (expr >= lo)) or (not (expr >= hi))
(not (expr >= lo)) or (not (expr <= hi))
the reason for this slightly convoluted form is that NaN's
are not considered to be in range in the float case. */
return emit_check
......@@ -5619,15 +5739,8 @@ process_type (Entity_Id gnat_entity)
pointers. */
if (gnu_old)
{
if (TREE_CODE (gnu_old) != TYPE_DECL
|| !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
{
/* If this was a withed access type, this is not an error
and merely indicates we've already elaborated the type
already. */
gcc_assert (Is_Type (gnat_entity) && From_With_Type (gnat_entity));
return;
}
gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
&& TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
save_gnu_tree (gnat_entity, NULL_TREE, false);
}
......@@ -6085,28 +6198,6 @@ gnat_stabilize_reference_1 (tree e, bool force)
TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
return result;
}
/* Build a global constructor or destructor function. METHOD_TYPE gives
the type of the function and CDTORS points to the list of constructor
or destructor functions to be invoked. FIXME: Migrate into cgraph. */
static void
build_global_cdtor (int method_type, tree *cdtors)
{
tree body = 0;
for (; *cdtors; *cdtors = TREE_CHAIN (*cdtors))
{
tree fn = TREE_VALUE (*cdtors);
tree fntype = TREE_TYPE (fn);
tree fnaddr = build1 (ADDR_EXPR, build_pointer_type (fntype), fn);
tree fncall = build3 (CALL_EXPR, TREE_TYPE (fntype), fnaddr, NULL_TREE,
NULL_TREE);
append_to_statement_list (fncall, &body);
}
cgraph_build_static_cdtor (method_type, body, DEFAULT_INIT_PRIORITY);
}
extern char *__gnat_to_canonical_file_spec (char *);
......
gcc/ada/utils.c
......@@ -42,6 +42,7 @@
#include "tree-inline.h"
#include "tree-gimple.h"
#include "tree-dump.h"
#include "pointer-set.h"
#include "ada.h"
#include "types.h"
......@@ -74,11 +75,6 @@ tree gnat_std_decls[(int) ADT_LAST];
/* Functions to call for each of the possible raise reasons. */
tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
/* List of functions called automatically at the beginning and
end of execution, on targets without .ctors/.dtors sections. */
tree static_ctors;
tree static_dtors;
/* Forward declarations for handlers of attributes. */
static tree handle_const_attribute (tree *, tree, tree, int, bool *);
static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *);
......@@ -99,6 +95,27 @@ const struct attribute_spec gnat_internal_attribute_table[] =
of `save_gnu_tree' for more info. */
static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
#define GET_GNU_TREE(GNAT_ENTITY) \
associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id]
#define SET_GNU_TREE(GNAT_ENTITY,VAL) \
associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL)
#define PRESENT_GNU_TREE(GNAT_ENTITY) \
(associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
/* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */
static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table;
#define GET_DUMMY_NODE(GNAT_ENTITY) \
dummy_node_table[(GNAT_ENTITY) - First_Node_Id]
#define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \
dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL)
#define PRESENT_DUMMY_NODE(GNAT_ENTITY) \
(dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
/* 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.
......@@ -130,6 +147,17 @@ static GTY(()) struct gnat_binding_level *current_binding_level;
/* A chain of gnat_binding_level structures awaiting reuse. */
static GTY((deletable)) struct gnat_binding_level *free_binding_level;
/* An array of global declarations. */
static GTY(()) VEC (tree,gc) *global_decls;
/* An array of global renaming pointers. */
static GTY(()) VEC (tree,gc) *global_renaming_pointers;
/* Arrays of functions called automatically at the beginning and
end of execution, on targets without .ctors/.dtors sections. */
static GTY(()) VEC (tree,gc) *static_ctors;
static GTY(()) VEC (tree,gc) *static_dtors;
/* A chain of unused BLOCK nodes. */
static GTY((deletable)) tree free_block_chain;
......@@ -172,10 +200,11 @@ save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
to something which is a decl. Raise gigi 401 if not. Usually, this
means GNAT_ENTITY is defined twice, but occasionally is due to some
Gigi problem. */
gcc_assert (!gnu_decl
|| (!associate_gnat_to_gnu[gnat_entity - First_Node_Id]
&& (no_check || DECL_P (gnu_decl))));
associate_gnat_to_gnu[gnat_entity - First_Node_Id] = gnu_decl;
gcc_assert (!(gnu_decl
&& (PRESENT_GNU_TREE (gnat_entity)
|| (!no_check && !DECL_P (gnu_decl)))));
SET_GNU_TREE (gnat_entity, gnu_decl);
}
/* GNAT_ENTITY is a GNAT tree node for a defining identifier.
......@@ -188,8 +217,8 @@ save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
tree
get_gnu_tree (Entity_Id gnat_entity)
{
gcc_assert (associate_gnat_to_gnu[gnat_entity - First_Node_Id]);
return associate_gnat_to_gnu[gnat_entity - First_Node_Id];
gcc_assert (PRESENT_GNU_TREE (gnat_entity));
return GET_GNU_TREE (gnat_entity);
}
/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
......@@ -197,9 +226,66 @@ get_gnu_tree (Entity_Id gnat_entity)
bool
present_gnu_tree (Entity_Id gnat_entity)
{
return (associate_gnat_to_gnu[gnat_entity - First_Node_Id]) != 0;
return PRESENT_GNU_TREE (gnat_entity);
}
/* Initialize the association of GNAT nodes to GCC trees as dummies. */
void
init_dummy_type (void)
{
dummy_node_table
= (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
}
/* Make a dummy type corresponding to GNAT_TYPE. */
tree
make_dummy_type (Entity_Id gnat_type)
{
Entity_Id gnat_underlying;
tree gnu_type;
enum tree_code code;
/* Find a full type for GNAT_TYPE, taking into account any class wide
types. */
if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
gnat_type = Equivalent_Type (gnat_type);
else if (Ekind (gnat_type) == E_Class_Wide_Type)
gnat_type = Root_Type (gnat_type);
/* Find a full view for GNAT_TYPE, looking through any incomplete or
private types. */
if (IN (Ekind (gnat_type), Incomplete_Kind)
&& From_With_Type (gnat_type))
gnat_underlying = Non_Limited_View (gnat_type);
else if (IN (Ekind (gnat_type), Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_type)))
gnat_underlying = Full_View (gnat_type);
else
gnat_underlying = gnat_type;
/* If it there already a dummy type, use that one. Else make one. */
if (PRESENT_DUMMY_NODE (gnat_underlying))
return GET_DUMMY_NODE (gnat_underlying);
/* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
it an ENUMERAL_TYPE. */
if (Is_Record_Type (gnat_underlying))
code = tree_code_for_record_type (gnat_underlying);
else
code = ENUMERAL_TYPE;
gnu_type = make_node (code);
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) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
SET_DUMMY_NODE (gnat_underlying, gnu_type);
return gnu_type;
}
/* Return nonzero if we are currently in the global binding level. */
......@@ -354,16 +440,20 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
add_decl_expr (decl, gnat_node);
/* 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
order. The list will be reversed later. Put global variables in the
globals list. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the
list, as 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))
if (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;
if (global_bindings_p ())
VEC_safe_push (tree, gc, global_decls, decl);
else
{
TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
BLOCK_VARS (current_binding_level->block) = decl;
}
}
/* For the declaration of a type, set its name if it either is not already
......@@ -494,6 +584,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
endlink)),
NULL_TREE, false, true, true, NULL,
Empty);
DECL_IS_MALLOC (malloc_decl) = 1;
/* free is a function declaration tree for a function to free memory. */
free_decl
......@@ -970,6 +1061,12 @@ write_record_type_debug_info (tree record_type)
var = true;
}
/* The heuristics above might get the alignment wrong.
Adjust the obvious case where align is smaller than the
alignments necessary for objects of field_type. */
if (align < TYPE_ALIGN(field_type))
align = TYPE_ALIGN(field_type);
/* Make a new field name, if necessary. */
if (var || align != 0)
{
......@@ -1229,6 +1326,9 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list,
DECL_ARTIFICIAL (type_decl) = artificial_p;
if (!TYPE_IS_DUMMY_P (type))
gnat_pushdecl (type_decl, gnat_node);
process_attributes (type_decl, attr_list);
/* Pass type declaration information to the debugger unless this is an
......@@ -1245,18 +1345,18 @@ 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, global_bindings_p (), 0);
if (!TYPE_IS_DUMMY_P (type))
gnat_pushdecl (type_decl, gnat_node);
return type_decl;
}
/* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
ASM_NAME is its assembler name (if provided). TYPE is its data type
(a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial
expression; NULL_TREE if none.
/* Helper for create_var_decl and create_true_var_decl. Returns a GCC VAR_DECL
or CONST_DECL node.
CONST_FLAG is true if this variable is constant.
VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
(if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is
the GCC tree for an optional initial expression; NULL_TREE if none.
CONST_FLAG is true if this variable is constant, in which case we might
return a CONST_DECL node unless CONST_DECL_ALLOWED_FLAG is false.
PUBLIC_FLAG is true if this definition is to be made visible outside of
the current compilation unit. This flag should be set when processing the
......@@ -1269,10 +1369,11 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list,
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,
bool const_flag, bool public_flag, bool extern_flag,
bool static_flag, struct attrib *attr_list, Node_Id gnat_node)
static tree
create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
bool const_flag, bool const_decl_allowed_flag,
bool public_flag, bool extern_flag, bool static_flag,
struct attrib *attr_list, Node_Id gnat_node)
{
bool init_const
= (!var_init
......@@ -1283,7 +1384,7 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
TREE_TYPE (var_init))
: TREE_CONSTANT (var_init))));
tree var_decl
= build_decl ((const_flag && init_const
= build_decl ((const_flag && const_decl_allowed_flag && init_const
/* Only make a CONST_DECL for sufficiently-small objects.
We consider complex double "sufficiently-small" */
&& TYPE_SIZE (type) != 0
......@@ -1351,6 +1452,38 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
return var_decl;
}
/* Wrapper around create_var_decl_1 for cases where we don't care whether
a VAR or a CONST decl node is created. */
tree
create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
bool const_flag, bool public_flag, bool extern_flag,
bool static_flag, struct attrib *attr_list,
Node_Id gnat_node)
{
return create_var_decl_1 (var_name, asm_name, type, var_init,
const_flag, true,
public_flag, extern_flag, static_flag,
attr_list, gnat_node);
}
/* Wrapper around create_var_decl_1 for cases where a VAR_DECL node is
required. The primary intent is for DECL_CONST_CORRESPONDING_VARs, which
must be VAR_DECLs and on which we want TREE_READONLY set to have them
possibly assigned to a readonly data section. */
tree
create_true_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
bool const_flag, bool public_flag, bool extern_flag,
bool static_flag, struct attrib *attr_list,
Node_Id gnat_node)
{
return create_var_decl_1 (var_name, asm_name, type, var_init,
const_flag, false,
public_flag, extern_flag, static_flag,
attr_list, gnat_node);
}
/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
......@@ -1466,11 +1599,6 @@ create_field_decl (tree field_name, tree field_type, tree record_type,
if (must_pass_by_ref (field_type) || default_pass_by_ref (field_type))
addressable = 1;
/* ??? For now, we say that any field of aggregate type is addressable
because the front end may take 'Reference of it. */
if (AGGREGATE_TYPE_P (field_type))
addressable = 1;
/* Mark the decl as nonaddressable if it is indicated so semantically,
meaning we won't ever attempt to take the address of the field.
......@@ -1589,6 +1717,29 @@ process_attributes (tree decl, struct attrib *attr_list)
}
}
/* Record a global renaming pointer. */
void
record_global_renaming_pointer (tree decl)
{
gcc_assert (DECL_RENAMED_OBJECT (decl));
VEC_safe_push (tree, gc, global_renaming_pointers, decl);
}
/* Invalidate the global renaming pointers. */
void
invalidate_global_renaming_pointers (void)
{
unsigned int i;
tree iter;
for (i = 0; VEC_iterate(tree, global_renaming_pointers, i, iter); i++)
SET_DECL_RENAMED_OBJECT (iter, NULL_TREE);
VEC_free (tree, gc, global_renaming_pointers);
}
/* Return true if VALUE is a known to be a multiple of FACTOR, which must be
a power of 2. */
......@@ -1700,6 +1851,19 @@ create_subprog_decl (tree subprog_name, tree asm_name,
DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1;
DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1;
/* TREE_ADDRESSABLE is set on the result type to request the use of the
target by-reference return mechanism. This is not supported all the
way down to RTL expansion with GCC 4, which ICEs on temporary creation
attempts with such a type and expects DECL_BY_REFERENCE to be set on
the RESULT_DECL instead - see gnat_genericize for more details. */
if (TREE_ADDRESSABLE (TREE_TYPE (DECL_RESULT (subprog_decl))))
{
tree result_decl = DECL_RESULT (subprog_decl);
TREE_ADDRESSABLE (TREE_TYPE (result_decl)) = 0;
DECL_BY_REFERENCE (result_decl) = 1;
}
if (inline_flag)
DECL_DECLARED_INLINE_P (subprog_decl) = 1;
......@@ -1744,6 +1908,163 @@ begin_subprog_body (tree subprog_decl)
get_pending_sizes ();
}
/* Helper for the genericization callback. Return a dereference of VAL
if it is of a reference type. */
static tree
convert_from_reference (tree val)
{
tree value_type, ref;
if (TREE_CODE (TREE_TYPE (val)) != REFERENCE_TYPE)
return val;
value_type = TREE_TYPE (TREE_TYPE (val));
ref = build1 (INDIRECT_REF, value_type, val);
/* See if what we reference is CONST or VOLATILE, which requires
looking into array types to get to the component type. */
while (TREE_CODE (value_type) == ARRAY_TYPE)
value_type = TREE_TYPE (value_type);
TREE_READONLY (ref)
= (TYPE_QUALS (value_type) & TYPE_QUAL_CONST);
TREE_THIS_VOLATILE (ref)
= (TYPE_QUALS (value_type) & TYPE_QUAL_VOLATILE);
TREE_SIDE_EFFECTS (ref)
= (TREE_THIS_VOLATILE (ref) || TREE_SIDE_EFFECTS (val));
return ref;
}
/* Helper for the genericization callback. Returns true if T denotes
a RESULT_DECL with DECL_BY_REFERENCE set. */
static inline bool
is_byref_result (tree t)
{
return (TREE_CODE (t) == RESULT_DECL && DECL_BY_REFERENCE (t));
}
/* Tree walking callback for gnat_genericize. Currently ...
o Adjust references to the function's DECL_RESULT if it is marked
DECL_BY_REFERENCE and so has had its type turned into a reference
type at the end of the function compilation. */
static tree
gnat_genericize_r (tree *stmt_p, int *walk_subtrees, void *data)
{
/* This implementation is modeled after what the C++ front-end is
doing, basis of the downstream passes behavior. */
tree stmt = *stmt_p;
struct pointer_set_t *p_set = (struct pointer_set_t*) data;
/* If we have a direct mention of the result decl, dereference. */
if (is_byref_result (stmt))
{
*stmt_p = convert_from_reference (stmt);
*walk_subtrees = 0;
return NULL;
}
/* Otherwise, no need to walk the the same tree twice. */
if (pointer_set_contains (p_set, stmt))
{
*walk_subtrees = 0;
return NULL_TREE;
}
/* If we are taking the address of what now is a reference, just get the
reference value. */
if (TREE_CODE (stmt) == ADDR_EXPR
&& is_byref_result (TREE_OPERAND (stmt, 0)))
{
*stmt_p = convert (TREE_TYPE (stmt), TREE_OPERAND (stmt, 0));
*walk_subtrees = 0;
}
/* Don't dereference an by-reference RESULT_DECL inside a RETURN_EXPR. */
else if (TREE_CODE (stmt) == RETURN_EXPR
&& TREE_OPERAND (stmt, 0)
&& is_byref_result (TREE_OPERAND (stmt, 0)))
*walk_subtrees = 0;
/* Don't look inside trees that cannot embed references of interest. */
else if (IS_TYPE_OR_DECL_P (stmt))
*walk_subtrees = 0;
pointer_set_insert (p_set, *stmt_p);
return NULL;
}
/* Perform lowering of Ada trees to GENERIC. In particular:
o Turn a DECL_BY_REFERENCE RESULT_DECL into a real by-reference decl
and adjust all the references to this decl accordingly. */
static void
gnat_genericize (tree fndecl)
{
/* Prior to GCC 4, an explicit By_Reference result mechanism for a function
was handled by simply setting TREE_ADDRESSABLE on the result type.
Everything required to actually pass by invisible ref using the target
mechanism (e.g. extra parameter) was handled at RTL expansion time.
This doesn't work with GCC 4 any more for several reasons. First, the
gimplification process might need the creation of temporaries of this
type, and the gimplifier ICEs on such attempts. Second, the middle-end
now relies on a different attribute for such cases (DECL_BY_REFERENCE on
RESULT/PARM_DECLs), and expects the user invisible by-reference-ness to
be explicitely accounted for by the front-end in the function body.
We achieve the complete transformation in two steps:
1/ create_subprog_decl performs early attribute tweaks: it clears
TREE_ADDRESSABLE from the result type and sets DECL_BY_REFERENCE on
the result decl. The former ensures that the bit isn't set in the GCC
tree saved for the function, so prevents ICEs on temporary creation.
The latter we use here to trigger the rest of the processing.
2/ This function performs the type transformation on the result decl
and adjusts all the references to this decl from the function body
accordingly.
Clearing TREE_ADDRESSABLE from the type differs from the C++ front-end
strategy, which escapes the gimplifier temporary creation issues by
creating it's own temporaries using TARGET_EXPR nodes. Our way relies
on simple specific support code in aggregate_value_p to look at the
target function result decl explicitely. */
struct pointer_set_t *p_set;
tree decl_result = DECL_RESULT (fndecl);
if (!DECL_BY_REFERENCE (decl_result))
return;
/* Make the DECL_RESULT explicitely by-reference and adjust all the
occurrences in the function body using the common tree-walking facility.
We want to see every occurrence of the result decl to adjust the
referencing tree, so need to use our own pointer set to control which
trees should be visited again or not. */
p_set = pointer_set_create ();
TREE_TYPE (decl_result) = build_reference_type (TREE_TYPE (decl_result));
TREE_ADDRESSABLE (decl_result) = 0;
relayout_decl (decl_result);
walk_tree (&DECL_SAVED_TREE (fndecl), gnat_genericize_r, p_set, NULL);
pointer_set_destroy (p_set);
}
/* Finish the definition of the current subprogram and compile it all the way
to assembler language output. BODY is the tree corresponding to
the subprogram. */
......@@ -1784,10 +2105,13 @@ end_subprog_body (tree body)
/* If we don't have .ctors/.dtors sections, and this is a static
constructor or destructor, it must be recorded now. */
if (DECL_STATIC_CONSTRUCTOR (fndecl) && !targetm.have_ctors_dtors)
static_ctors = tree_cons (NULL_TREE, fndecl, static_ctors);
VEC_safe_push (tree, gc, static_ctors, fndecl);
if (DECL_STATIC_DESTRUCTOR (fndecl) && !targetm.have_ctors_dtors)
static_dtors = tree_cons (NULL_TREE, fndecl, static_dtors);
VEC_safe_push (tree, gc, static_dtors, fndecl);
/* Perform the required pre-gimplfication transformations on the tree. */
gnat_genericize (fndecl);
/* We do different things for nested and non-nested functions.
??? This should be in cgraph. */
......@@ -3371,7 +3695,6 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
/* Search the chain of currently reachable declarations for a builtin
FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE).
Return the first node found, if any, or NULL_TREE otherwise. */
tree
builtin_decl_for (tree name __attribute__ ((unused)))
{
......@@ -3380,5 +3703,78 @@ builtin_decl_for (tree name __attribute__ ((unused)))
return NULL_TREE;
}
/* Return the appropriate GCC tree code for the specified GNAT type,
the latter being a record type as predicated by Is_Record_Type. */
enum tree_code
tree_code_for_record_type (Entity_Id gnat_type)
{
Node_Id component_list
= Component_List (Type_Definition
(Declaration_Node
(Implementation_Base_Type (gnat_type))));
Node_Id component;
/* Make this a UNION_TYPE unless it's either not an Unchecked_Union or
we have a non-discriminant field outside a variant. In either case,
it's a RECORD_TYPE. */
if (!Is_Unchecked_Union (gnat_type))
return RECORD_TYPE;
for (component = First_Non_Pragma (Component_Items (component_list));
Present (component);
component = Next_Non_Pragma (component))
if (Ekind (Defining_Entity (component)) == E_Component)
return RECORD_TYPE;
return UNION_TYPE;
}
/* Build a global constructor or destructor function. METHOD_TYPE gives
the type of the function and VEC points to the vector of constructor
or destructor functions to be invoked. FIXME: Migrate into cgraph. */
static void
build_global_cdtor (int method_type, tree *vec, int len)
{
tree body = NULL_TREE;
int i;
for (i = 0; i < len; i++)
{
tree fntype = TREE_TYPE (vec[i]);
tree fnaddr = build1 (ADDR_EXPR, build_pointer_type (fntype), vec[i]);
tree fncall = build3 (CALL_EXPR, TREE_TYPE (fntype), fnaddr, NULL_TREE,
NULL_TREE);
append_to_statement_list (fncall, &body);
}
if (body)
cgraph_build_static_cdtor (method_type, body, DEFAULT_INIT_PRIORITY);
}
/* Perform final processing on global variables. */
void
gnat_write_global_declarations (void)
{
/* Generate functions to call static constructors and destructors
for targets that do not support .ctors/.dtors sections. These
functions have magic names which are detected by collect2. */
build_global_cdtor ('I', VEC_address (tree, static_ctors),
VEC_length (tree, static_ctors));
build_global_cdtor ('D', VEC_address (tree, static_dtors),
VEC_length (tree, static_dtors));
/* Proceed to optimize and emit assembly.
FIXME: shouldn't be the front end's responsibility to call this. */
cgraph_optimize ();
/* Emit debug info for all global declarations. */
emit_debug_global_declarations (VEC_address (tree, global_decls),
VEC_length (tree, global_decls));
}
#include "gt-ada-utils.h"
#include "gtype-ada.h"
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