git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

decl.c (gnat_to_gnu_entity): Reorder local variables. 

* gcc-interface/decl.c (gnat_to_gnu_entity): Reorder local variables.
	* gcc-interface/trans.c: Fix formatting throughout.  Fix comments.
	* gcc-interface/utils.c: Fix comments.

From-SVN: r145658
This commit is contained in:
Eric Botcazou 2009-04-07 08:26:08 +00:00 committed by Eric Botcazou
parent 229077b0b4
commit 1e17ef870e
4 changed files with 265 additions and 275 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/ada/ChangeLog
View File

@ -1,9 +1,17 @@
2009-04-07 Eric Botcazou <ebotcazou@adacore.com>
* decl.c (compile_time_known_address_p): Rewrite and move around.
* gcc-interface/decl.c (gnat_to_gnu_entity): Reorder local variables.
* gcc-interface/trans.c: Fix formatting throughout. Fix comments.
* gcc-interface/utils.c: Fix comments.
2009-04-07 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (compile_time_known_address_p): Rewrite and
move around.
(gnat_to_gnu_type): Move around.
(get_unpadded_type): Likewise.
* utils.c (update_pointer_to): Use synthetic macro. Tidy comments.
* gcc-interface/utils.c (update_pointer_to): Use synthetic macro.
Tidy comments.
2009-04-07 Eric Botcazou <ebotcazou@adacore.com>

117
gcc/ada/gcc-interface/decl.c
View File

@ -155,17 +155,16 @@ static int compatible_signatures_p (tree ftype1, tree ftype2);
static void rest_of_type_decl_compilation_no_defer (tree);
/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
entity, this routine returns the equivalent GCC tree for that entity
(an ..._DECL node) and associates the ..._DECL node with the input GNAT
defining identifier.
entity, return the equivalent GCC tree for that entity (a ..._DECL node)
and associate the ..._DECL node with the input GNAT defining identifier.
If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
initial value (in GCC tree form). This is optional for variables.
For renamed entities, GNU_EXPR gives the object being renamed.
initial value (in GCC tree form). This is optional for a variable. For
a renamed entity, GNU_EXPR gives the object being renamed.
DEFINITION is nonzero if this call is intended for a definition. This is
used for separate compilation where it necessary to know whether an
external declaration or a definition should be created if the GCC equivalent
used for separate compilation where it is necessary to know whether an
external declaration or a definition must be created if the GCC equivalent
was not created previously. The value of 1 is normally used for a nonzero
DEFINITION, but a value of 2 is used in special circumstances, defined in
the code. */
@ -174,27 +173,34 @@ tree
gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
Entity_Id gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
tree gnu_entity_id;
tree gnu_type = NULL_TREE;
/* Contains the gnu XXXX_DECL tree node which is equivalent to the input
GNAT tree. This node will be associated with the GNAT node by calling
the save_gnu_tree routine at the end of the `switch' statement. */
Entity_Id gnat_temp;
Entity_Kind kind = Ekind (gnat_entity);
/* Contains the GCC DECL node which is equivalent to the input GNAT node.
This node will be associated with the GNAT node by calling at the end
of the `switch' statement. */
tree gnu_decl = NULL_TREE;
/* true if we have already saved gnu_decl as a gnat association. */
/* Contains the GCC type to be used for the GCC node. */
tree gnu_type = NULL_TREE;
/* Contains the GCC size tree to be used for the GCC node. */
tree gnu_size = NULL_TREE;
/* Contains the GCC name to be used for the GCC node. */
tree gnu_entity_id;
/* True if we have already saved gnu_decl as a GNAT association. */
bool saved = false;
/* Nonzero if we incremented defer_incomplete_level. */
/* True if we incremented defer_incomplete_level. */
bool this_deferred = false;
/* Nonzero if we incremented force_global. */
/* True if we incremented force_global. */
bool this_global = false;
/* Nonzero if we should check to see if elaborated during processing. */
/* True if we should check to see if elaborated during processing. */
bool maybe_present = false;
/* Nonzero if we made GNU_DECL and its type here. */
/* True if we made GNU_DECL and its type here. */
bool this_made_decl = false;
struct attrib *attr_list = NULL;
/* True if debug info is requested for this entity. */
bool debug_info_p = (Needs_Debug_Info (gnat_entity)
|| debug_info_level == DINFO_LEVEL_VERBOSE);
Entity_Kind kind = Ekind (gnat_entity);
Entity_Id gnat_temp;
/* True if this entity is to be considered as imported. */
bool imported_p = (Is_Imported (gnat_entity)
&& No (Address_Clause (gnat_entity)));
unsigned int esize
= ((Known_Esize (gnat_entity)
&& UI_Is_In_Int_Range (Esize (gnat_entity)))
@ -204,22 +210,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
: IN (kind, Access_Kind) ? POINTER_SIZE * 2
: LONG_LONG_TYPE_SIZE)
: LONG_LONG_TYPE_SIZE);
tree gnu_size = 0;
bool imported_p
= (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
unsigned int align = 0;
struct attrib *attr_list = NULL;
/* Since a use of an Itype is a definition, process it as such if it
is not in a with'ed unit. */
if (!definition && Is_Itype (gnat_entity)
if (!definition
&& Is_Itype (gnat_entity)
&& !present_gnu_tree (gnat_entity)
&& In_Extended_Main_Code_Unit (gnat_entity))
{
/* Ensure that we are in a subprogram mentioned in the Scope
chain of this entity, our current scope is global,
or that we encountered a task or entry (where we can't currently
accurately check scoping). */
/* Ensure that we are in a subprogram mentioned in the Scope chain of
this entity, our current scope is global, or we encountered a task
or entry (where we can't currently accurately check scoping). */
if (!current_function_decl
|| DECL_ELABORATION_PROC_P (current_function_decl))
{
@ -228,7 +231,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
for (gnat_temp = Scope (gnat_entity);
Present (gnat_temp); gnat_temp = Scope (gnat_temp))
Present (gnat_temp);
gnat_temp = Scope (gnat_temp))
{
if (Is_Type (gnat_temp))
gnat_temp = Underlying_Type (gnat_temp);
@ -254,21 +258,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
}
/* This abort means the entity "gnat_entity" has an incorrect scope,
i.e. that its scope does not correspond to the subprogram in which
it is declared */
/* This abort means the entity has an incorrect scope, i.e. that its
scope does not correspond to the subprogram it is declared in. */
gcc_unreachable ();
}
/* If this is entity 0, something went badly wrong. */
/* If the entiy is not present, something went badly wrong. */
gcc_assert (Present (gnat_entity));
/* If we've already processed this entity, return what we got last time.
If we are defining the node, we should not have already processed it.
In that case, we will abort below when we try to save a new GCC tree for
this object. We also need to handle the case of getting a dummy type
when a Full_View exists. */
In that case, we will abort below when we try to save a new GCC tree
for this object. We also need to handle the case of getting a dummy
type when a Full_View exists. */
if (present_gnu_tree (gnat_entity)
&& (!definition || (Is_Type (gnat_entity) && imported_p)))
{
@ -279,9 +281,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& IN (kind, Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity)))
{
gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
NULL_TREE, 0);
gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
save_gnu_tree (gnat_entity, NULL_TREE, false);
save_gnu_tree (gnat_entity, gnu_decl, false);
}
@ -293,14 +294,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
Esize must be specified unless it was specified by the programmer. */
gcc_assert (!Unknown_Esize (gnat_entity)
|| Has_Size_Clause (gnat_entity)
|| (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind)
|| (!IN (kind, Numeric_Kind)
&& !IN (kind, Enumeration_Kind)
&& (!IN (kind, Access_Kind)
|| kind == E_Access_Protected_Subprogram_Type
|| kind == E_Anonymous_Access_Protected_Subprogram_Type
|| kind == E_Access_Subtype)));
/* Likewise, RM_Size must be specified for all discrete and fixed-point
types. */
/* RM_Size must be specified for all discrete and fixed-point types. */
gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
|| !Unknown_RM_Size (gnat_entity));
@ -319,7 +320,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| IN (kind, Type_Kind));
/* For cases when we are not defining (i.e., we are referencing from
another compilation unit) Public entities, show we are at global level
another compilation unit) public entities, show we are at global level
for the purpose of computing scopes. Don't do this for components or
discriminants since the relevant test is whether or not the record is
being defined. But do this for Imported functions or procedures in
@ -410,7 +411,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
the regular processing take place, which leaves us with a regular
exception data object for VMS exceptions too. The condition code
mapping is taken care of by the front end and the bitmasking by the
runtime library. */
runtime library. */
goto object;
case E_Discriminant:
@ -426,7 +427,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
stored discriminants, return the entity for the corresponding
stored discriminant. Also use Original_Record_Component
if the record has a private extension. */
if (Present (Original_Record_Component (gnat_entity))
&& Original_Record_Component (gnat_entity) != gnat_entity)
{
@ -441,14 +441,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
then it is an untagged record. If the Corresponding_Discriminant
is not empty then this must be a renamed discriminant and its
Original_Record_Component must point to the corresponding explicit
stored discriminant (i.e., we should have taken the previous
stored discriminant (i.e. we should have taken the previous
branch). */
else if (Present (Corresponding_Discriminant (gnat_entity))
&& Is_Tagged_Type (gnat_record))
{
/* A tagged record has no explicit stored discriminants. */
gcc_assert (First_Discriminant (gnat_record)
== First_Stored_Discriminant (gnat_record));
gnu_decl
@ -471,9 +469,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
it is an untagged record. If the Corresponding_Discriminant
is not empty then this must be a renamed discriminant and its
Original_Record_Component must point to the corresponding explicit
stored discriminant (i.e., we should have taken the first
stored discriminant (i.e. we should have taken the first
branch). */
else if (Present (Corresponding_Discriminant (gnat_entity))
&& (First_Discriminant (gnat_record)
!= First_Stored_Discriminant (gnat_record)))
@ -3281,7 +3278,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
either gnat_desig_full or gnat_desig_equiv. */
Entity_Id gnat_desig_rep;
/* Nonzero if this is a pointer to an unconstrained array. */
/* True if this is a pointer to an unconstrained array. */
bool is_unconstrained_array;
/* We want to know if we'll be seeing the freeze node for any
@ -3291,9 +3288,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
? In_Extended_Main_Code_Unit (gnat_desig_full)
: In_Extended_Main_Code_Unit (gnat_desig_type));
/* Nonzero if we make a dummy type here. */
/* True if we make a dummy type here. */
bool got_fat_p = false;
/* Nonzero if the dummy is a fat pointer. */
/* True if the dummy is a fat pointer. */
bool made_dummy = false;
tree gnu_desig_type = NULL_TREE;
enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
@ -5483,10 +5480,10 @@ maybe_variable (tree gnu_operand)
type definition (either a bound or a discriminant value) for GNAT_ENTITY,
return the GCC tree to use for that expression. GNU_NAME is the
qualification to use if an external name is appropriate and DEFINITION is
nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
we need a result. Otherwise, we are just elaborating this for
side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
purposes even if it isn't needed for code generation. */
true if this is a definition of GNAT_ENTITY. If NEED_VALUE is true, we
need a result. Otherwise, we are just elaborating this for side-effects.
If NEED_DEBUG is true we need the symbol for debugging purposes even if it
isn't needed for code generation. */
static tree
elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
@ -7285,7 +7282,7 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
/* Given a type TYPE, return a new type whose size is appropriate for SIZE.
If TYPE is the best type, return it. Otherwise, make a new type. We
only support new integral and pointer types. FOR_BIASED is nonzero if
only support new integral and pointer types. FOR_BIASED is true if
we are making a biased type. */
static tree

395
gcc/ada/gcc-interface/trans.c
View File

@ -58,7 +58,6 @@
#include "ada-tree.h"
#include "gigi.h"
#include "adadecode.h"
#include "dwarf2.h"
#include "dwarf2out.h"
@ -74,10 +73,9 @@
#endif
/* For efficient float-to-int rounding, it is necessary to know whether
floating-point arithmetic may use wider intermediate results.
When FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
floating-point arithmetic does not widen if double precision is emulated. */
floating-point arithmetic may use wider intermediate results. When
FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
that arithmetic does not widen if double precision is emulated. */
#ifndef FP_ARITH_MAY_WIDEN
#if defined(HAVE_extendsfdf2)
#define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
@ -100,12 +98,12 @@ struct String_Entry *Strings_Ptr;
Char_Code *String_Chars_Ptr;
struct List_Header *List_Headers_Ptr;
/* Current filename without path. */
/* Current filename without path. */
const char *ref_filename;
/* If true, then gigi is being called on an analyzed but unexpanded
/* True when gigi is being called on an analyzed but unexpanded
tree, and the only purpose of the call is to properly annotate
types with representation information. */
types with representation information. */
bool type_annotate_only;
/* When not optimizing, we cache the 'First, 'Last and 'Length attributes
@ -140,8 +138,8 @@ struct language_function GTY(())
struct stmt_group GTY((chain_next ("%h.previous"))) {
struct stmt_group *previous; /* Previous code group. */
tree stmt_list; /* List of statements for this code group. */
tree block; /* BLOCK for this code group, if any. */
tree stmt_list; /* List of statements for this code group. */
tree block; /* BLOCK for this code group, if any. */
tree cleanups; /* Cleanups for this code group, if any. */
};
@ -156,7 +154,7 @@ static GTY((deletable)) struct stmt_group *stmt_group_free_list;
??? gnat_node should be Node_Id, but gengtype gets confused. */
struct elab_info GTY((chain_next ("%h.next"))) {
struct elab_info *next; /* Pointer to next in chain. */
struct elab_info *next; /* Pointer to next in chain. */
tree elab_proc; /* Elaboration procedure. */
int gnat_node; /* The N_Compilation_Unit. */
};
@ -275,7 +273,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
the name table gets reallocated after Gigi returns but before all the
debugging information is output. The __gnat_to_canonical_file_spec
call translates filenames from pragmas Source_Reference that contain
host style syntax not understood by gdb. */
host style syntax not understood by gdb. */
const char *filename
= IDENTIFIER_POINTER
(get_identifier
@ -601,8 +599,8 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
required if this is a static expression because it might be used
in a context where a dereference is inappropriate, such as a case
statement alternative or a record discriminant. There is no possible
volatile-ness short-circuit here since Volatile constants must be imported
per C.6. */
volatile-ness short-circuit here since Volatile constants must bei
imported per C.6. */
if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type)
&& !Is_Imported (gnat_temp)
&& Present (Address_Clause (gnat_temp)))
@ -1061,7 +1059,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
gnu_expr = gnu_prefix;
/* Remove NOPS from gnu_expr and conversions from gnu_prefix.
We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
while (TREE_CODE (gnu_expr) == NOP_EXPR)
gnu_expr = TREE_OPERAND (gnu_expr, 0);
@ -1112,15 +1110,21 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
{
Node_Id gnat_deref = Prefix (gnat_node);
Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
Node_Id gnat_actual_subtype
= Actual_Designated_Subtype (gnat_deref);
tree gnu_ptr_type
= TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
&& Present (gnat_actual_subtype))
{
tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type, get_identifier ("SIZE"));
}
&& Present (gnat_actual_subtype))
{
tree gnu_actual_obj_type
= gnat_to_gnu_type (gnat_actual_subtype);
gnu_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
get_identifier ("SIZE"));
}
gnu_result = TYPE_SIZE (gnu_type);
}
@ -1381,7 +1385,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
prefix_unused = true;
/* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
the result is 0. Don't allow 'Bit on a bare component, though. */
the result is 0. Don't allow 'Bit on a bare component, though. */
if (attribute == Attr_Bit
&& TREE_CODE (gnu_prefix) != COMPONENT_REF
&& TREE_CODE (gnu_prefix) != FIELD_DECL)
@ -1452,7 +1456,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
}
/* If this has a PLACEHOLDER_EXPR, qualify it by the object
we are handling. */
we are handling. */
gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
break;
}
@ -1554,7 +1558,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
/* If this is an attribute where the prefix was unused, force a use of it if
it has a side-effect. But don't do it if the prefix is just an entity
name. However, if an access check is needed, we must do it. See second
example in AARM 11.6(5.e). */
example in AARM 11.6(5.e). */
if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
&& !Is_Entity_Name (Prefix (gnat_node)))
gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
@ -1680,7 +1684,7 @@ Case_Statement_to_gnu (Node_Id gnat_node)
}
}
/* Now emit a definition of the label all the cases branched to. */
/* Now emit a definition of the label all the cases branched to. */
add_stmt (build1 (LABEL_EXPR, void_type_node,
TREE_VALUE (gnu_switch_label_stack)));
gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
@ -2373,7 +2377,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
/* If we have not saved a GCC object for the formal, it means it is an
Out parameter not passed by reference and that does not need to be
copied in. Otherwise, look at the PARM_DECL to see if it is passed by
reference. */
reference. */
if (gnu_formal
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_REF_P (gnu_formal))
@ -2408,7 +2412,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
}
/* 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. */
since arguments don't know that they will be passed by ref. */
gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
}
@ -3087,7 +3091,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
set_cfun (NULL);
/* For a body, first process the spec if there is one. */
/* For a body, first process the spec if there is one. */
if (Nkind (Unit (gnat_node)) == N_Package_Body
|| (Nkind (Unit (gnat_node)) == N_Subprogram_Body
&& !Acts_As_Spec (gnat_node)))
@ -3151,7 +3155,7 @@ 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 = error_mark_node; /* Default to no value. */
tree gnu_result_type = void_type_node;
tree gnu_expr;
tree gnu_lhs, gnu_rhs;
@ -3214,7 +3218,7 @@ gnat_to_gnu (Node_Id gnat_node)
switch (Nkind (gnat_node))
{
/********************************/
/* Chapter 2: Lexical Elements: */
/* Chapter 2: Lexical Elements */
/********************************/
case N_Identifier:
@ -3274,12 +3278,12 @@ gnat_to_gnu (Node_Id gnat_node)
}
/* We should never see a Vax_Float type literal, since the front end
is supposed to transform these using appropriate conversions */
is supposed to transform these using appropriate conversions. */
else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
gcc_unreachable ();
else
{
{
Ureal ur_realval = Realval (gnat_node);
gnu_result_type = get_unpadded_type (Etype (gnat_node));
@ -3340,9 +3344,9 @@ gnat_to_gnu (Node_Id gnat_node)
int i;
char *string;
if (length >= ALLOCA_THRESHOLD)
string = XNEWVEC (char, length + 1); /* in case of large strings */
else
string = (char *) alloca (length + 1);
string = XNEWVEC (char, length + 1);
else
string = (char *) alloca (length + 1);
/* Build the string with the characters in the literal. Note
that Ada strings are 1-origin. */
@ -3359,8 +3363,8 @@ gnat_to_gnu (Node_Id gnat_node)
this to not be converted to the array type. */
TREE_TYPE (gnu_result) = gnu_result_type;
if (length >= ALLOCA_THRESHOLD) /* free if heap-allocated */
free (string);
if (length >= ALLOCA_THRESHOLD)
free (string);
}
else
{
@ -3395,7 +3399,7 @@ gnat_to_gnu (Node_Id gnat_node)
break;
/**************************************/
/* Chapter 3: Declarations and Types: */
/* Chapter 3: Declarations and Types */
/**************************************/
case N_Subtype_Declaration:
@ -3502,7 +3506,7 @@ gnat_to_gnu (Node_Id gnat_node)
break;
/*************************************/
/* Chapter 4: Names and Expressions: */
/* Chapter 4: Names and Expressions */
/*************************************/
case N_Explicit_Dereference:
@ -3625,7 +3629,7 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_base_max_expr));
/* Build a slice index check that returns the low bound,
assuming the slice is not empty. */
assuming the slice is not empty. */
gnu_expr = emit_check
(build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
gnu_expr_l, gnu_expr_h),
@ -3675,21 +3679,18 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_prefix = maybe_implicit_deref (gnu_prefix);
/* For discriminant references in tagged types always substitute the
corresponding discriminant as the actual selected component. */
corresponding discriminant as the actual selected component. */
if (Is_Tagged_Type (gnat_pref_type))
while (Present (Corresponding_Discriminant (gnat_field)))
gnat_field = Corresponding_Discriminant (gnat_field);
/* For discriminant references of untagged types always substitute the
corresponding stored discriminant. */
corresponding stored discriminant. */
else if (Present (Corresponding_Discriminant (gnat_field)))
gnat_field = Original_Record_Component (gnat_field);
/* Handle extracting the real or imaginary part of a complex.
The real part is the first field and the imaginary the last. */
if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
? REALPART_EXPR : IMAGPART_EXPR,
@ -3698,9 +3699,8 @@ gnat_to_gnu (Node_Id gnat_node)
{
gnu_field = gnat_to_gnu_field_decl (gnat_field);
/* If there are discriminants, the prefix might be
evaluated more than once, which is a problem if it has
side-effects. */
/* If there are discriminants, the prefix might be evaluated more
than once, which is a problem if it has side-effects. */
if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
? Designated_Type (Etype
(Prefix (gnat_node)))
@ -3720,8 +3720,8 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Attribute_Reference:
{
/* The attribute designator (like an enumeration value). */
int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
/* The attribute designator (like an enumeration value). */
int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
/* The Elab_Spec and Elab_Body attributes are special in that
Prefix is a unit, not an object with a GCC equivalent. Similarly
@ -3863,7 +3863,7 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_high = gnat_to_gnu (High_Bound (gnat_range));
}
else if (Nkind (gnat_range) == N_Identifier
|| Nkind (gnat_range) == N_Expanded_Name)
|| Nkind (gnat_range) == N_Expanded_Name)
{
tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
@ -3961,7 +3961,7 @@ gnat_to_gnu (Node_Id gnat_node)
/* If the result type is a private type, its full view may be a
numeric subtype. The representation we need is that of its base
type, given that it is the result of an arithmetic operation. */
else if (Is_Private_Type (Etype (gnat_node)))
else if (Is_Private_Type (Etype (gnat_node)))
gnu_type = gnu_result_type
= get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
@ -4023,12 +4023,12 @@ gnat_to_gnu (Node_Id gnat_node)
do overflow checking, do it here. The goal is to push
the expansions further into the back end over time. */
if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
&& (Nkind (gnat_node) == N_Op_Add
&& (Nkind (gnat_node) == N_Op_Add
|| Nkind (gnat_node) == N_Op_Subtract
|| Nkind (gnat_node) == N_Op_Multiply)
&& !TYPE_UNSIGNED (gnu_type)
&& !FLOAT_TYPE_P (gnu_type))
gnu_result
gnu_result
= build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs);
else
gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
@ -4053,10 +4053,10 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Conditional_Expression:
{
tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
tree gnu_false
= gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
tree gnu_false
= gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = build_cond_expr (gnu_result_type,
@ -4091,10 +4091,10 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
if (Ekind (Etype (gnat_node)) != E_Private_Type)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
else
gnu_result_type = get_unpadded_type (Base_Type
(Full_View (Etype (gnat_node))));
gnu_result_type = get_unpadded_type (Base_Type
(Full_View (Etype (gnat_node))));
if (Do_Overflow_Check (gnat_node)
&& !TYPE_UNSIGNED (gnu_result_type)
@ -4130,8 +4130,8 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_init = gnat_to_gnu (Expression (gnat_temp));
gnu_init = maybe_unconstrained_array (gnu_init);
if (Do_Range_Check (Expression (gnat_temp)))
gnu_init = emit_range_check (gnu_init, gnat_desig_type);
if (Do_Range_Check (Expression (gnat_temp)))
gnu_init = emit_range_check (gnu_init, gnat_desig_type);
if (Is_Elementary_Type (gnat_desig_type)
|| Is_Constrained (gnat_desig_type))
@ -4159,9 +4159,9 @@ gnat_to_gnu (Node_Id gnat_node)
}
break;
/***************************/
/* Chapter 5: Statements: */
/***************************/
/**************************/
/* Chapter 5: Statements */
/**************************/
case N_Label:
gnu_result = build1 (LABEL_EXPR, void_type_node,
@ -4226,7 +4226,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_If_Statement:
{
tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
/* Make the outer COND_EXPR. Avoid non-determinism. */
gnu_result = build3 (COND_EXPR, void_type_node,
@ -4340,7 +4340,7 @@ gnat_to_gnu (Node_Id gnat_node)
if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
&& Nkind (Expression (gnat_node)) == N_Function_Call)
{
gnu_lhs
gnu_lhs
= build_unary_op (INDIRECT_REF, NULL_TREE,
DECL_ARGUMENTS (current_function_decl));
gnu_result = call_to_gnu (Expression (gnat_node),
@ -4352,7 +4352,7 @@ gnat_to_gnu (Node_Id gnat_node)
if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
/* The original return type was unconstrained so dereference
the TARGET pointer in the actual return value's type. */
the TARGET pointer in the actual return value's type. */
gnu_lhs
= build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
DECL_ARGUMENTS (current_function_decl));
@ -4411,15 +4411,15 @@ gnat_to_gnu (Node_Id gnat_node)
gnat_to_gnu (Name (gnat_node)));
break;
/****************************/
/* Chapter 6: Subprograms: */
/****************************/
/***************************/
/* Chapter 6: Subprograms */
/***************************/
case N_Subprogram_Declaration:
/* Unless there is a freeze node, declare the subprogram. We consider
this a "definition" even though we're not generating code for
the subprogram because we will be making the corresponding GCC
node here. */
node here. */
if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
@ -4458,9 +4458,9 @@ gnat_to_gnu (Node_Id gnat_node)
break;
case N_Defining_Program_Unit_Name:
/* For a child unit identifier go up a level to get the
specification. We get this when we try to find the spec of
a child unit package that is the compilation unit being compiled. */
/* For a child unit identifier go up a level to get the specification.
We get this when we try to find the spec of a child unit package
that is the compilation unit being compiled. */
gnu_result = gnat_to_gnu (Parent (gnat_node));
break;
@ -4474,9 +4474,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
break;
/*************************/
/* Chapter 7: Packages: */
/*************************/
/************************/
/* Chapter 7: Packages */
/************************/
case N_Package_Declaration:
gnu_result = gnat_to_gnu (Specification (gnat_node));
@ -4492,7 +4492,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Package_Body:
/* If this is the body of a generic package - do nothing */
/* If this is the body of a generic package - do nothing. */
if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
{
gnu_result = alloc_stmt_list ();
@ -4508,19 +4508,19 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = end_stmt_group ();
break;
/*********************************/
/* Chapter 8: Visibility Rules: */
/*********************************/
/********************************/
/* Chapter 8: Visibility Rules */
/********************************/
case N_Use_Package_Clause:
case N_Use_Type_Clause:
/* Nothing to do here - but these may appear in list of declarations */
/* Nothing to do here - but these may appear in list of declarations. */
gnu_result = alloc_stmt_list ();
break;
/***********************/
/* Chapter 9: Tasks: */
/***********************/
/*********************/
/* Chapter 9: Tasks */
/*********************/
case N_Protected_Type_Declaration:
gnu_result = alloc_stmt_list ();
@ -4531,9 +4531,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = alloc_stmt_list ();
break;
/***********************************************************/
/* Chapter 10: Program Structure and Compilation Issues: */
/***********************************************************/
/*********************************************************/
/* Chapter 10: Program Structure and Compilation Issues */
/*********************************************************/
case N_Compilation_Unit:
@ -4559,7 +4559,7 @@ gnat_to_gnu (Node_Id gnat_node)
break;
/***************************/
/* Chapter 11: Exceptions: */
/* Chapter 11: Exceptions */
/***************************/
case N_Handled_Sequence_Of_Statements:
@ -4615,9 +4615,9 @@ gnat_to_gnu (Node_Id gnat_node)
= TREE_CHAIN (gnu_program_error_label_stack);
break;
/*******************************/
/* Chapter 12: Generic Units: */
/*******************************/
/******************************/
/* Chapter 12: Generic Units */
/******************************/
case N_Generic_Function_Renaming_Declaration:
case N_Generic_Package_Renaming_Declaration:
@ -4632,10 +4632,10 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = alloc_stmt_list ();
break;
/***************************************************/
/* Chapter 13: Representation Clauses and */
/* Implementation-Dependent Features: */
/***************************************************/
/**************************************************/
/* Chapter 13: Representation Clauses and */
/* Implementation-Dependent Features */
/**************************************************/
case N_Attribute_Definition_Clause:
gnu_result = alloc_stmt_list ();
@ -4705,7 +4705,7 @@ gnat_to_gnu (Node_Id gnat_node)
build_string (strlen (clobber) + 1, clobber),
gnu_clobbers);
/* Then perform some standard checking and processing on the
/* 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);
@ -4770,9 +4770,9 @@ gnat_to_gnu (Node_Id gnat_node)
break;
/***************************************************/
/* Added Nodes */
/***************************************************/
/****************/
/* Added Nodes */
/****************/
case N_Freeze_Entity:
start_stmt_group ();
@ -4825,13 +4825,13 @@ gnat_to_gnu (Node_Id gnat_node)
if (Present (Actual_Designated_Subtype (gnat_node)))
{
gnu_actual_obj_type
= gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
= gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
gnu_actual_obj_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
get_identifier ("DEALLOC"));
gnu_actual_obj_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
get_identifier ("DEALLOC"));
}
else
gnu_actual_obj_type = gnu_obj_type;
@ -4949,7 +4949,7 @@ gnat_to_gnu (Node_Id gnat_node)
if ((TYPE_DUMMY_P (gnu_target_desig_type)
|| get_alias_set (gnu_target_desig_type) != 0)
&& (!POINTER_TYPE_P (gnu_source_type)
&& (!POINTER_TYPE_P (gnu_source_type)
|| (TYPE_DUMMY_P (gnu_source_desig_type)
!= TYPE_DUMMY_P (gnu_target_desig_type))
|| (TYPE_DUMMY_P (gnu_source_desig_type)
@ -5695,7 +5695,7 @@ elaborate_all_entities (Node_Id gnat_node)
&& !IN (Ekind (gnat_entity), Named_Kind)
&& !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
@ -5744,7 +5744,7 @@ process_freeze_entity (Node_Id gnat_node)
= present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
/* If this entity has an Address representation clause, GNU_OLD is the
address, so discard it here. */
address, so discard it here. */
if (Present (Address_Clause (gnat_entity)))
gnu_old = 0;
@ -5758,7 +5758,7 @@ process_freeze_entity (Node_Id gnat_node)
/* Don't do anything for subprograms that may have been elaborated before
their freeze nodes. This can happen, for example because of an inner call
in an instance body, or a previous compilation of a spec for inlining
purposes. */
purposes. */
if (gnu_old
&& ((TREE_CODE (gnu_old) == FUNCTION_DECL
&& (Ekind (gnat_entity) == E_Function
@ -5790,7 +5790,7 @@ process_freeze_entity (Node_Id gnat_node)
/* Reset the saved tree, if any, and elaborate the object or type for real.
If there is a full declaration, elaborate it and copy the type to
GNAT_ENTITY. Likewise if this is the record subtype corresponding to
a class wide type or subtype. */
a class wide type or subtype. */
if (gnu_old)
{
save_gnu_tree (gnat_entity, NULL_TREE, false);
@ -5888,7 +5888,7 @@ process_inlined_subprograms (Node_Id gnat_node)
static void
process_decls (List_Id gnat_decls, List_Id gnat_decls2,
Node_Id gnat_end_list, bool pass1p, bool pass2p)
Node_Id gnat_end_list, bool pass1p, bool pass2p)
{
List_Id gnat_decl_array[2];
Node_Id gnat_decl;
@ -5926,7 +5926,7 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
&& Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
record_code_position (gnat_decl);
else if (Nkind (gnat_decl) == N_Package_Body_Stub
else if (Nkind (gnat_decl) == N_Package_Body_Stub
&& Present (Library_Unit (gnat_decl))
&& Present (Freeze_Node
(Corresponding_Spec
@ -5947,25 +5947,27 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
}
}
/* For bodies and stubs that act as their own specs, the entity
itself must be elaborated in the first pass, because it may
be used in other declarations. */
/* For bodies and stubs that act as their own specs, the entity
itself must be elaborated in the first pass, because it may
be used in other declarations. */
else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
{
Node_Id gnat_subprog_id =
Defining_Entity (Specification (gnat_decl));
Node_Id gnat_subprog_id
= Defining_Entity (Specification (gnat_decl));
if (Ekind (gnat_subprog_id) != E_Subprogram_Body
&& Ekind (gnat_subprog_id) != E_Generic_Procedure
&& Ekind (gnat_subprog_id) != E_Generic_Procedure
&& Ekind (gnat_subprog_id) != E_Generic_Function)
gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
}
}
/* Concurrent stubs stand for the corresponding subprogram bodies,
which are deferred like other bodies. */
else if (Nkind (gnat_decl) == N_Task_Body_Stub
|| Nkind (gnat_decl) == N_Protected_Body_Stub)
;
else
add_stmt (gnat_to_gnu (gnat_decl));
}
@ -6149,8 +6151,8 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
case MULT_EXPR:
/* The check here is designed to be efficient if the rhs is constant,
but it will work for any rhs by using integer division.
Four different check expressions determine wether X * C overflows,
but it will work for any rhs by using integer division.
Four different check expressions determine wether X * C overflows,
depending on C.
C == 0 => false
C > 0 => X > type_max / C || X < type_min / C
@ -6217,14 +6219,14 @@ emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
< TYPE_PRECISION (get_base_type (gnu_range_type))))
return gnu_expr;
/* Checked expressions must be evaluated only once. */
/* Checked expressions must be evaluated only once. */
gnu_expr = protect_multiple_eval (gnu_expr);
/* 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))
the reason for this slightly convoluted form is that NaNs
are not considered to be in range in the float case. */
(not (expr >= lo)) or (not (expr <= hi))
the reason for this slightly convoluted form is that NaNs
are not considered to be in range in the float case. */
return emit_check
(build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
invert_truthvalue
@ -6239,27 +6241,24 @@ emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
gnu_expr, CE_Range_Check_Failed);
}
/* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
which we are about to index, GNU_EXPR is the index expression to be
checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
against which GNU_EXPR has to be checked. Note that for index
checking we cannot use the emit_range_check function (although very
similar code needs to be generated in both cases) since for index
checking the array type against which we are checking the indices
may be unconstrained and consequently we need to retrieve the
actual index bounds from the array object itself
(GNU_ARRAY_OBJECT). The place where we need to do that is in
subprograms having unconstrained array formal parameters */
/* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which
we are about to index, GNU_EXPR is the index expression to be checked,
GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
has to be checked. Note that for index checking we cannot simply use the
emit_range_check function (although very similar code needs to be generated
in both cases) since for index checking the array type against which we are
checking the indices may be unconstrained and consequently we need to get
the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
The place where we need to do that is in subprograms having unconstrained
array formal parameters. */
static tree
emit_index_check (tree gnu_array_object,
tree gnu_expr,
tree gnu_low,
tree gnu_high)
emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
tree gnu_high)
{
tree gnu_expr_check;
/* Checked expressions must be evaluated only once. */
/* Checked expressions must be evaluated only once. */
gnu_expr = protect_multiple_eval (gnu_expr);
/* Must do this computation in the base type in case the expression's
@ -6267,7 +6266,7 @@ emit_index_check (tree gnu_array_object,
gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
/* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
the object we are handling. */
the object we are handling. */
gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
@ -6311,11 +6310,10 @@ emit_check (tree gnu_cond, tree gnu_expr, int reason)
return save_expr (gnu_result);
}
/* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
overflow checks if OVERFLOW_P is nonzero and range checks if
RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
If TRUNCATE_P is nonzero, do a float to integer conversion with
truncation; otherwise round. */
/* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
checks if OVERFLOW_P is true and range checks if RANGE_P is true.
GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
float to integer conversion with truncation; otherwise round. */
static tree
convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
@ -6410,8 +6408,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
gnu_out_ub))));
if (!integer_zerop (gnu_cond))
gnu_result = emit_check (gnu_cond, gnu_input,
CE_Overflow_Check_Failed);
gnu_result
= emit_check (gnu_cond, gnu_input, CE_Overflow_Check_Failed);
}
/* Now convert to the result base type. If this is a non-truncating
@ -6425,51 +6423,49 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
const struct real_format *fmt;
/* The following calculations depend on proper rounding to even
of each arithmetic operation. In order to prevent excess
precision from spoiling this property, use the widest hardware
floating-point type if FP_ARITH_MAY_WIDEN is true. */
of each arithmetic operation. In order to prevent excess
precision from spoiling this property, use the widest hardware
floating-point type if FP_ARITH_MAY_WIDEN is true. */
calc_type
= FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
calc_type = (FP_ARITH_MAY_WIDEN ? longest_float_type_node
: gnu_in_basetype);
/* FIXME: Should not have padding in the first place */
/* FIXME: Should not have padding in the first place. */
if (TREE_CODE (calc_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (calc_type))
calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
&& TYPE_IS_PADDING_P (calc_type))
calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
/* Compute the exact value calc_type'Pred (0.5) at compile time. */
/* Compute the exact value calc_type'Pred (0.5) at compile time. */
fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
half_minus_pred_half);
half_minus_pred_half);
gnu_pred_half = build_real (calc_type, pred_half);
/* If the input is strictly negative, subtract this value
and otherwise add it from the input. For 0.5, the result
is exactly between 1.0 and the machine number preceding 1.0
(for calc_type). Since the last bit of 1.0 is even, this 0.5
will round to 1.0, while all other number with an absolute
value less than 0.5 round to 0.0. For larger numbers exactly
halfway between integers, rounding will always be correct as
the true mathematical result will be closer to the higher
integer compared to the lower one. So, this constant works
for all floating-point numbers.
and otherwise add it from the input. For 0.5, the result
is exactly between 1.0 and the machine number preceding 1.0
(for calc_type). Since the last bit of 1.0 is even, this 0.5
will round to 1.0, while all other number with an absolute
value less than 0.5 round to 0.0. For larger numbers exactly
halfway between integers, rounding will always be correct as
the true mathematical result will be closer to the higher
integer compared to the lower one. So, this constant works
for all floating-point numbers.
The reason to use the same constant with subtract/add instead
of a positive and negative constant is to allow the comparison
to be scheduled in parallel with retrieval of the constant and
conversion of the input to the calc_type (if necessary).
*/
The reason to use the same constant with subtract/add instead
of a positive and negative constant is to allow the comparison
to be scheduled in parallel with retrieval of the constant and
conversion of the input to the calc_type (if necessary). */
gnu_zero = convert (gnu_in_basetype, integer_zero_node);
gnu_saved_result = save_expr (gnu_result);
gnu_conv = convert (calc_type, gnu_saved_result);
gnu_comp = build2 (GE_EXPR, integer_type_node,
gnu_saved_result, gnu_zero);
gnu_saved_result, gnu_zero);
gnu_add_pred_half
= build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
= build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
gnu_subtract_pred_half
= build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
= build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
gnu_result = build3 (COND_EXPR, calc_type, gnu_comp,
gnu_add_pred_half, gnu_subtract_pred_half);
}
@ -6622,7 +6618,7 @@ addressable_p (tree gnu_expr, tree gnu_type)
check the alignment of the containing record, as it is
guaranteed to be not smaller than that of its most
aligned field that is not a bit-field. */
&& (!STRICT_ALIGNMENT
&& (!STRICT_ALIGNMENT
|| DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
>= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
/* The field of a padding record is always addressable. */
@ -6688,7 +6684,7 @@ process_type (Entity_Id gnat_entity)
elaborate_entity (gnat_entity);
if (!gnu_old)
{
{
tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
make_dummy_type (gnat_entity),
NULL, false, false, gnat_entity);
@ -6726,9 +6722,7 @@ process_type (Entity_Id gnat_entity)
/* If this is a record type corresponding to a task or protected type
that is a completion of an incomplete type, perform a similar update
on the type. */
/* ??? Including protected types here is a guess. */
on the type. ??? Including protected types here is a guess. */
if (IN (Ekind (gnat_entity), Record_Kind)
&& Is_Concurrent_Record_Type (gnat_entity)
&& present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
@ -6770,7 +6764,7 @@ assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
/* The expander is supposed to put a single component selector name
in every record component association */
in every record component association. */
gcc_assert (No (Next (gnat_field)));
/* Ignore fields that have Corresponding_Discriminants since we'll
@ -6810,15 +6804,15 @@ assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
return gnu_result;
}
/* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
is the first element of an array aggregate. It may itself be an
aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
of the array component. It is needed for range checking. */
/* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
the first element of an array aggregate. It may itself be an aggregate.
GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
GNAT_COMPONENT_TYPE is the type of the array component; it is needed
for range checking. */
static tree
pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
Entity_Id gnat_component_type)
Entity_Id gnat_component_type)
{
tree gnu_expr_list = NULL_TREE;
tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
@ -6841,7 +6835,7 @@ pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
gnu_expr = gnat_to_gnu (gnat_expr);
/* before assigning the element to the array make sure it is
in range */
in range. */
if (Do_Range_Check (gnat_expr))
gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
}
@ -7066,7 +7060,7 @@ maybe_stabilize_reference (tree ref, bool force, bool *success)
case ERROR_MARK:
ref = error_mark_node;
/* ... Fallthru to failure ... */
/* ... fall through to failure ... */
/* If arg isn't a kind of lvalue we recognize, make no change.
Caller should recognize the error for an invalid lvalue. */
@ -7235,9 +7229,7 @@ static const char *
extract_encoding (const char *name)
{
char *encoding = GGC_NEWVEC (char, strlen (name));
get_encoding (name, encoding);
return encoding;
}
@ -7247,9 +7239,7 @@ static const char *
decode_name (const char *name)
{
char *decoded = GGC_NEWVEC (char, strlen (name) * 2 + 60);
__gnat_decode (name, decoded, 0);
return decoded;
}
@ -7356,11 +7346,8 @@ post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
integer to write in the message. */
void
post_error_ne_tree_2 (const char *msg,
Node_Id node,
Entity_Id ent,
tree t,
int num)
post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
int num)
{
Error_Msg_Uint_2 = UI_From_Int (num);
post_error_ne_tree (msg, node, ent, t);

16
gcc/ada/gcc-interface/utils.c
View File

@ -210,7 +210,7 @@ init_gnat_to_gnu (void)
/* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
which is to be associated with GNAT_ENTITY. Such GCC tree node is always
a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed.
a ..._DECL node. If NO_CHECK is true, the latter check is suppressed.
If GNU_DECL is zero, a previous association is to be reset. */
@ -1252,13 +1252,11 @@ get_parallel_type (tree type)
}
/* Utility function of above to merge LAST_SIZE, the previous size of a record
with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero
if this represents a QUAL_UNION_TYPE in which case we must look for
COND_EXPRs and replace a value of zero with the old size. If HAS_REP
is nonzero, we must take the MAX of the end position of this field
with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE.
We return an expression for the size. */
with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this
represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and
replace a value of zero with the old size. If HAS_REP is true, we take the
MAX of the end position of this field with LAST_SIZE. In all other cases,
we use FIRST_BIT plus SIZE. Return an expression for the size. */
static tree
merge_sizes (tree last_size, tree first_bit, tree size, bool special,
@ -1499,7 +1497,7 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list,
definition to be made visible outside of the current compilation unit, for
instance variable definitions in a package specification.
EXTERN_FLAG is nonzero when processing an external variable declaration (as
EXTERN_FLAG is true when processing an external variable declaration (as
opposed to a definition: no storage is to be allocated for the variable).
STATIC_FLAG is only relevant when not at top level. In that case