* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
- * ware Foundation; either version 2, or (at your option) any later ver- *
+ * ware Foundation; either version 3, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
- * Public License distributed with GNAT; see file COPYING. If not, write *
- * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
- * Boston, MA 02110-1301, USA. *
+ * Public License distributed with GNAT; see file COPYING3. If not see *
+ * <http://www.gnu.org/licenses/>. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
-#include "real.h"
#include "flags.h"
-#include "toplev.h"
-#include "rtl.h"
#include "expr.h"
#include "ggc.h"
-#include "cgraph.h"
-#include "function.h"
-#include "except.h"
-#include "debug.h"
#include "output.h"
#include "tree-iterator.h"
#include "gimple.h"
+
#include "ada.h"
+#include "adadecode.h"
#include "types.h"
#include "atree.h"
#include "elists.h"
#include "einfo.h"
#include "ada-tree.h"
#include "gigi.h"
-#include "adadecode.h"
-#include "dwarf2.h"
-#include "dwarf2out.h"
/* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
for fear of running out of stack space. If we need more, we use xmalloc
/* When not optimizing, we cache the 'First, 'Last and 'Length attributes
of unconstrained array IN parameters to avoid emitting a great deal of
redundant instructions to recompute them each time. */
-struct parm_attr GTY (())
-{
+struct GTY (()) parm_attr {
int id; /* GTY doesn't like Entity_Id. */
int dim;
tree first;
DEF_VEC_P(parm_attr);
DEF_VEC_ALLOC_P(parm_attr,gc);
-struct language_function GTY(())
-{
+struct GTY(()) language_function {
VEC(parm_attr,gc) *parm_attr_cache;
};
of a IF. In the case where it represents a lexical scope, we may also
have a BLOCK node corresponding to it and/or cleanups. */
-struct stmt_group GTY((chain_next ("%h.previous"))) {
+struct GTY((chain_next ("%h.previous"))) stmt_group {
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. */
??? gnat_node should be Node_Id, but gengtype gets confused. */
-struct elab_info GTY((chain_next ("%h.next"))) {
+struct GTY((chain_next ("%h.next"))) elab_info {
struct elab_info *next; /* Pointer to next in chain. */
tree elab_proc; /* Elaboration procedure. */
int gnat_node; /* The N_Compilation_Unit. */
type_annotate_only = (gigi_operating_mode == 1);
+ gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
+
+ /* Declare the name of the compilation unit as the first global
+ name in order to make the middle-end fully deterministic. */
+ t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
+ first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
+
for (i = 0; i < number_files; i++)
{
/* Use the identifier table to make a permanent copy of the filename as
/* Initialize ourselves. */
init_code_table ();
init_gnat_to_gnu ();
- gnat_compute_largest_alignment ();
init_dummy_type ();
/* If we are just annotating types, give VOID_TYPE zero sizes to avoid
if (!Stack_Check_Probes_On_Target)
set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
+ /* Retrieve alignment settings. */
+ double_float_alignment = get_target_double_float_alignment ();
+ double_scalar_alignment = get_target_double_scalar_alignment ();
+
/* Record the builtin types. Define `integer' and `unsigned char' first so
that dbx will output them first. */
record_builtin_type ("integer", integer_type_node);
/* Make the types and functions used for exception processing. */
jmpbuf_type
= build_array_type (gnat_type_for_mode (Pmode, 0),
- build_index_type (build_int_cst (NULL_TREE, 5)));
+ build_index_type (size_int (5)));
record_builtin_type ("JMPBUF_T", jmpbuf_type);
jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
= build_qualified_type (TREE_TYPE (raise_nodefer_decl),
TYPE_QUAL_VOLATILE);
- long_long_float_type
- = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
-
- if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
- {
- /* In this case, the builtin floating point types are VAX float,
- so make up a type for use. */
- longest_float_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (longest_float_type_node);
- record_builtin_type ("longest float type", longest_float_type_node);
- }
- else
- longest_float_type_node = TREE_TYPE (long_long_float_type);
-
/* Build the special descriptor type and its null node if needed. */
if (TARGET_VTABLE_USES_DESCRIPTORS)
{
null_list = tree_cons (field, null_node, null_list);
}
- finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
+ finish_record_type (fdesc_type_node, nreverse (field_list), 0, true);
+ record_builtin_type ("descriptor", fdesc_type_node);
null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
}
+ long_long_float_type
+ = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
+
+ if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
+ {
+ /* In this case, the builtin floating point types are VAX float,
+ so make up a type for use. */
+ longest_float_type_node = make_node (REAL_TYPE);
+ TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
+ layout_type (longest_float_type_node);
+ record_builtin_type ("longest float type", longest_float_type_node);
+ }
+ else
+ longest_float_type_node = TREE_TYPE (long_long_float_type);
+
/* Dummy objects to materialize "others" and "all others" in the exception
tables. These are exported by a-exexpr.adb, so see this unit for the
types to use. */
if (Exception_Mechanism == Back_End_Exceptions)
gnat_init_gcc_eh ();
- gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
-
- /* Declare the name of the compilation unit as the first global
- name in order to make the middle-end fully deterministic. */
- t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
- first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
-
/* Now translate the compilation unit proper. */
start_stmt_group ();
Compilation_Unit_to_gnu (gnat_root);
attached to the CONST_DECL. */
return (aliased != 0
/* This should match the constant case of the renaming code. */
- || Is_Composite_Type (Etype (Name (gnat_parent)))
+ || Is_Composite_Type
+ (Underlying_Type (Etype (Name (gnat_parent))))
|| Nkind (Name (gnat_parent)) == N_Identifier);
+ case N_Object_Declaration:
+ /* We cannot use a constructor if this is an atomic object because
+ the actual assignment might end up being done component-wise. */
+ return Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
+ && Is_Atomic (Defining_Entity (gnat_parent));
+
+ case N_Assignment_Statement:
+ /* We cannot use a constructor if the LHS is an atomic object because
+ the actual assignment might end up being done component-wise. */
+ return Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
+ && Is_Atomic (Entity (Name (gnat_parent)));
+
default:
return 0;
}
return gnu_result;
}
\f
-/* Issue an error message if GNAT_NODE references an eliminated entity. */
-
-static void
-check_for_eliminated_entity (Node_Id gnat_node)
-{
- switch (Nkind (gnat_node))
- {
- case N_Identifier:
- case N_Operator_Symbol:
- case N_Expanded_Name:
- case N_Attribute_Reference:
- if (Is_Eliminated (Entity (gnat_node)))
- Eliminate_Error_Msg (gnat_node, Entity (gnat_node));
- break;
- }
-}
-
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
+/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
where we should place the result type. ATTRIBUTE is the attribute ID. */
static tree
Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
{
- tree gnu_result = error_mark_node;
- tree gnu_result_type;
- tree gnu_expr;
- bool prefix_unused = false;
tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
tree gnu_type = TREE_TYPE (gnu_prefix);
+ tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
+ bool prefix_unused = false;
/* If the input is a NULL_EXPR, make a new one. */
if (TREE_CODE (gnu_prefix) == NULL_EXPR)
{
- *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
- return build1 (NULL_EXPR, *gnu_result_type_p,
- TREE_OPERAND (gnu_prefix, 0));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ *gnu_result_type_p = gnu_result_type;
+ return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
}
switch (attribute)
{
case Attr_Pos:
case Attr_Val:
- /* These are just conversions until since representation clauses for
- enumerations are handled in the front end. */
+ /* These are just conversions since representation clauses for
+ enumeration types are handled in the front-end. */
{
bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
-
gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
case Attr_Pred:
case Attr_Succ:
- /* These just add or subject the constant 1. Representation clauses for
- enumerations are handled in the front-end. */
+ /* These just add or subtract the constant 1 since representation
+ clauses for enumeration types are handled in the front-end. */
gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
}
gnu_result
- = build_binary_op (attribute == Attr_Pred
- ? MINUS_EXPR : PLUS_EXPR,
+ = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
gnu_result_type, gnu_expr,
convert (gnu_result_type, integer_one_node));
break;
case Attr_Address:
case Attr_Unrestricted_Access:
- /* Conversions don't change something's address but can cause us to miss
- the COMPONENT_REF case below, so strip them off. */
+ /* Conversions don't change addresses but can cause us to miss the
+ COMPONENT_REF case below, so strip them off. */
gnu_prefix = remove_conversions (gnu_prefix,
!Must_Be_Byte_Aligned (gnat_node));
don't try to build a trampoline. */
if (attribute == Attr_Code_Address)
{
- check_for_eliminated_entity (Prefix (gnat_node));
-
for (gnu_expr = gnu_result;
CONVERT_EXPR_P (gnu_expr);
gnu_expr = TREE_OPERAND (gnu_expr, 0))
a useful warning with -Wtrampolines. */
else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
{
- check_for_eliminated_entity (Prefix (gnat_node));
-
for (gnu_expr = gnu_result;
CONVERT_EXPR_P (gnu_expr);
gnu_expr = TREE_OPERAND (gnu_expr, 0))
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- /* If this is an unconstrained array, we know the object must have been
- allocated with the template in front of the object. So compute the
- template address.*/
+ /* If this is an unconstrained array, we know the object has been
+ allocated with the template in front of the object. So compute
+ the template address. */
if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr
= convert (build_pointer_type
case Attr_Max_Size_In_Storage_Elements:
gnu_expr = gnu_prefix;
- /* Remove NOPS from gnu_expr and conversions from 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. */
while (TREE_CODE (gnu_expr) == NOP_EXPR)
gnu_expr = TREE_OPERAND (gnu_expr, 0);
/* If we're looking for the size of a field, return the field size.
Otherwise, if the prefix is an object, or if 'Object_Size or
'Max_Size_In_Storage_Elements has been specified, the result is the
- GCC size of the type. Otherwise, the result is the RM_Size of the
+ GCC size of the type. Otherwise, the result is the RM size of the
type. */
if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
|| attribute == Attr_Max_Size_In_Storage_Elements)
{
/* If this is a padded type, the GCC size isn't relevant to the
- programmer. Normally, what we want is the RM_Size, which was set
+ programmer. Normally, what we want is the RM size, which was set
from the specified size, but if it was not set, we want the size
of the relevant field. Using the MAX of those two produces the
right result in all case. Don't use the size of the field if it's
gcc_assert (gnu_result);
- /* Deal with a self-referential size by returning the maximum size for a
- type and by qualifying the size with the object for 'Size of an
+ /* Deal with a self-referential size by returning the maximum size for
+ a type and by qualifying the size with the object for 'Size of an
object. */
if (CONTAINS_PLACEHOLDER_P (gnu_result))
{
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- /* Always perform division using unsigned arithmetic as the size cannot
- be negative, but may be an overflowed positive value. This provides
- correct results for sizes up to 512 MB.
-
- ??? Size should be calculated in storage elements directly. */
-
if (attribute == Attr_Max_Size_In_Storage_Elements)
- gnu_result = convert (sizetype,
- fold_build2 (CEIL_DIV_EXPR, bitsizetype,
- gnu_result, bitsize_unit_node));
+ gnu_result = fold_build2 (CEIL_DIV_EXPR, bitsizetype,
+ gnu_result, bitsize_unit_node);
break;
case Attr_Alignment:
- if (TREE_CODE (gnu_prefix) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
- gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
+ {
+ unsigned int align;
- gnu_type = TREE_TYPE (gnu_prefix);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- prefix_unused = true;
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF
+ && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
+ == RECORD_TYPE)
+ && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
+ gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
- gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF
- ? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))
- : TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT);
+ gnu_type = TREE_TYPE (gnu_prefix);
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ prefix_unused = true;
+
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
+ align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
+ else
+ {
+ Node_Id gnat_prefix = Prefix (gnat_node);
+ Entity_Id gnat_type = Etype (gnat_prefix);
+ unsigned int double_align;
+ bool is_capped_double, align_clause;
+
+ /* If the default alignment of "double" or larger scalar types is
+ specifically capped and there is an alignment clause neither
+ on the type nor on the prefix itself, return the cap. */
+ if ((double_align = double_float_alignment) > 0)
+ is_capped_double
+ = is_double_float_or_array (gnat_type, &align_clause);
+ else if ((double_align = double_scalar_alignment) > 0)
+ is_capped_double
+ = is_double_scalar_or_array (gnat_type, &align_clause);
+ else
+ is_capped_double = align_clause = false;
+
+ if (is_capped_double
+ && Nkind (gnat_prefix) == N_Identifier
+ && Present (Alignment_Clause (Entity (gnat_prefix))))
+ align_clause = true;
+
+ if (is_capped_double && !align_clause)
+ align = double_align;
+ else
+ align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
+ }
+
+ gnu_result = size_int (align);
+ }
break;
case Attr_First:
much rarer cases, for extremely large arrays we expect
never to encounter in practice. In addition, the former
computation required the use of potentially constraining
- signed arithmetic while the latter doesn't. Note that the
+ signed arithmetic while the latter doesn't. Note that the
comparison must be done in the original index base type,
otherwise the conversion of either bound to gnu_compute_type
may overflow. */
break;
}
- /* If this has a PLACEHOLDER_EXPR, qualify it by the object
- we are handling. */
+ /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
+ handling. */
gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
break;
}
break;
case Attr_Null_Parameter:
- /* This is just a zero cast to the pointer type for
- our prefix and dereferenced. */
+ /* This is just a zero cast to the pointer type for our prefix and
+ dereferenced. */
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result
= build_unary_op (INDIRECT_REF, NULL_TREE,
default:
/* Say we have an unimplemented attribute. Then set the value to be
- returned to be a zero and hope that's something we can convert to the
- type of this attribute. */
+ returned to be a zero and hope that's something we can convert to
+ the type of this attribute. */
post_error ("unimplemented attribute", gnat_node);
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = integer_zero_node;
ptr_void_type_node,
NULL_TREE),
NULL_TREE, 0, 1, 1, 0, Empty);
+
+ /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */
+ DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
}
/* Do nothing if the establish builtin is not available, which might happen
this happens. The foreign or exported condition is expected to satisfy
all the constraints. */
if (TARGET_ABI_OPEN_VMS
- && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node)))
+ && (Has_Foreign_Convention (gnat_subprog_id)
+ || Is_Exported (gnat_subprog_id)))
establish_gnat_vms_condition_handler ();
process_decls (Declarations (gnat_node), Empty, Empty, true, true);
tree gnu_after_list = NULL_TREE;
tree gnu_subprog_call;
- check_for_eliminated_entity (Name (gnat_node));
-
gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
/* If we are calling a stubbed function, make this into a raise of
gnat_formal);
}
- /* Remove any unpadding from the object and reset the copy. */
- if (TREE_CODE (gnu_name) == COMPONENT_REF
- && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
+ /* If the actual type of the object is already the nominal type,
+ we have nothing to do, except if the size is self-referential
+ in which case we'll remove the unpadding below. */
+ if (TREE_TYPE (gnu_name) == gnu_name_type
+ && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
+ ;
+
+ /* Otherwise remove unpadding from the object and reset the copy. */
+ else if (TREE_CODE (gnu_name) == COMPONENT_REF
+ && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
+ == RECORD_TYPE)
+ && (TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
/* Otherwise convert to the nominal type of the object if it's
else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
&& (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
|| smaller_packable_type_p (TREE_TYPE (gnu_name),
- gnu_name_type)))
+ gnu_name_type)))
gnu_name = convert (gnu_name_type, gnu_name);
/* Make a SAVE_EXPR to both properly account for potential side
invalidate_global_renaming_pointers ();
}
\f
+/* Return whether GNAT_NODE, an unchecked type conversion, is on the LHS
+ of an assignment and a no-op as far as gigi is concerned. */
+
+static bool
+unchecked_conversion_lhs_nop (Node_Id gnat_node)
+{
+ Entity_Id from_type, to_type;
+
+ /* The conversion must be on the LHS of an assignment. Otherwise, even
+ if the conversion was essentially a no-op, it could de facto ensure
+ type consistency and this should be preserved. */
+ if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement
+ && Name (Parent (gnat_node)) == gnat_node))
+ return false;
+
+ from_type = Etype (Expression (gnat_node));
+
+ /* We're interested in artificial conversions generated by the front-end
+ to make private types explicit, e.g. in Expand_Assign_Array. */
+ if (!Is_Private_Type (from_type))
+ return false;
+
+ from_type = Underlying_Type (from_type);
+ to_type = Etype (gnat_node);
+
+ /* The direct conversion to the underlying type is a no-op. */
+ if (to_type == from_type)
+ return true;
+
+ /* For an array type, the conversion to the PAT is a no-op. */
+ if (Ekind (from_type) == E_Array_Subtype
+ && to_type == Packed_Array_Type (from_type))
+ return true;
+
+ return false;
+}
+
/* This function is the driver of the GNAT to GCC tree transformation
process. It is the entry point of the tree transformer. GNAT_NODE is the
root of some GNAT tree. Return the root of the corresponding GCC tree.
case N_Unchecked_Type_Conversion:
gnu_result = gnat_to_gnu (Expression (gnat_node));
+
+ /* Skip further processing if the conversion is deemed a no-op. */
+ if (unchecked_conversion_lhs_nop (gnat_node))
+ {
+ gnu_result_type = TREE_TYPE (gnu_result);
+ break;
+ }
+
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* If the result is a pointer type, see if we are improperly
if (gnu_result
&& EXPR_P (gnu_result)
&& TREE_CODE (gnu_result) != NOP_EXPR
- && !REFERENCE_CLASS_P (gnu_result))
+ && !REFERENCE_CLASS_P (gnu_result)
+ && !EXPR_HAS_LOCATION (gnu_result))
set_expr_location_from_node (gnu_result, gnat_node);
/* If we're supposed to return something of void_type, it means we have
if (TREE_CODE (gnu_result_type) == VOID_TYPE)
return gnu_result;
- /* If the result is a constant that overflows, raise constraint error. */
- else if (TREE_CODE (gnu_result) == INTEGER_CST
- && TREE_OVERFLOW (gnu_result))
+ /* If the result is a constant that overflowed, raise Constraint_Error. */
+ if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
{
post_error ("Constraint_Error will be raised at run-time?", gnat_node);
-
gnu_result
= build1 (NULL_EXPR, gnu_result_type,
build_call_raise (CE_Overflow_Check_Failed, gnat_node,
1. If this is the Name of an assignment statement or a parameter of
a procedure call, return the result almost unmodified since the
RHS will have to be converted to our type in that case, unless
- the result type has a simpler size. Similarly, don't convert
+ the result type has a simpler size. Likewise if there is just
+ a no-op unchecked conversion in-between. Similarly, don't convert
integral types that are the operands of an unchecked conversion
since we need to ignore those conversions (for 'Valid).
if (Present (Parent (gnat_node))
&& ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
&& Name (Parent (gnat_node)) == gnat_node)
+ || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
+ && unchecked_conversion_lhs_nop (Parent (gnat_node)))
|| (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
&& Name (Parent (gnat_node)) != gnat_node)
|| Nkind (Parent (gnat_node)) == N_Parameter_Association
Note that walk_tree knows how to deal with TYPE_DECL, but neither
VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
mark_visited (&gnu_stmt);
+
if (TREE_CODE (gnu_decl) == VAR_DECL
|| TREE_CODE (gnu_decl) == CONST_DECL)
{
mark_visited (&DECL_SIZE_UNIT (gnu_decl));
mark_visited (&DECL_INITIAL (gnu_decl));
}
- /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
- if (TREE_CODE (gnu_decl) == TYPE_DECL
- && (TREE_CODE (type) == RECORD_TYPE
- || TREE_CODE (type) == UNION_TYPE
- || TREE_CODE (type) == QUAL_UNION_TYPE)
- && (t = TYPE_ADA_SIZE (type)))
- mark_visited (&t);
+
+ /* In any case, we have to deal with our own fields. */
+ else if (TREE_CODE (gnu_decl) == TYPE_DECL)
+ switch (TREE_CODE (type))
+ {
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ case QUAL_UNION_TYPE:
+ if ((t = TYPE_ADA_SIZE (type)))
+ mark_visited (&t);
+ break;
+
+ case INTEGER_TYPE:
+ case ENUMERAL_TYPE:
+ case BOOLEAN_TYPE:
+ case REAL_TYPE:
+ if ((t = TYPE_RM_MIN_VALUE (type)))
+ mark_visited (&t);
+ if ((t = TYPE_RM_MAX_VALUE (type)))
+ mark_visited (&t);
+ break;
+
+ default:
+ break;
+ }
}
else
add_stmt_with_node (gnu_stmt, gnat_entity);
int needed_precision = precision * 2;
if (code == MULT_EXPR && precision == 64)
- {
+ {
tree int_64 = gnat_type_for_size (64, 0);
return convert (gnu_type, build_call_2_expr (mulv64_decl,
}
else if (needed_precision <= BITS_PER_WORD
- || (code == MULT_EXPR
+ || (code == MULT_EXPR
&& needed_precision <= LONG_LONG_TYPE_SIZE))
{
tree wide_type = gnat_type_for_size (needed_precision, 0);
if (!TREE_SIDE_EFFECTS (exp))
return exp;
- /* If it is a conversion, protect what's inside the conversion.
+ /* If this is a conversion, protect what's inside the conversion.
Similarly, if we're indirectly referencing something, we only
- actually need to protect the address since the data itself can't
- change in these situations. */
- else if (TREE_CODE (exp) == NON_LVALUE_EXPR
- || CONVERT_EXPR_P (exp)
- || TREE_CODE (exp) == VIEW_CONVERT_EXPR
- || TREE_CODE (exp) == INDIRECT_REF
- || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
- return build1 (TREE_CODE (exp), type,
- protect_multiple_eval (TREE_OPERAND (exp, 0)));
-
- /* If EXP is a fat pointer or something that can be placed into a register,
- just make a SAVE_EXPR. */
+ need to protect the address since the data itself can't change
+ in these situations. */
+ if (TREE_CODE (exp) == NON_LVALUE_EXPR
+ || CONVERT_EXPR_P (exp)
+ || TREE_CODE (exp) == VIEW_CONVERT_EXPR
+ || TREE_CODE (exp) == INDIRECT_REF
+ || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
+ return build1 (TREE_CODE (exp), type,
+ protect_multiple_eval (TREE_OPERAND (exp, 0)));
+
+ /* If this is a fat pointer or something that can be placed into a
+ register, just make a SAVE_EXPR. */
if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
return save_expr (exp);
- /* Otherwise, dereference, protect the address, and re-reference. */
- else
- return
- build_unary_op (INDIRECT_REF, type,
- save_expr (build_unary_op (ADDR_EXPR,
- build_reference_type (type),
- exp)));
+ /* Otherwise, reference, protect the address and dereference. */
+ return
+ build_unary_op (INDIRECT_REF, type,
+ save_expr (build_unary_op (ADDR_EXPR,
+ build_reference_type (type),
+ exp)));
}
\f
/* This is equivalent to stabilize_reference in tree.c, but we know how to
OSDN Git Service
