OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

gigi.h (build_call_raise_column): Adjust prototype. 

* gcc-interface/gigi.h (build_call_raise_column): Adjust prototype.
	(build_call_raise_range): Likewise.
	(gnat_unsigned_type): Delete.
	(gnat_signed_type): Likewise.
	(gnat_signed_or_unsigned_type_for): New prototype.
	(gnat_unsigned_type_for): New inline function.
	(gnat_signed_type_for): Likewise.
	* gcc-interface/cuintp.c (build_cst_from_int): Call build_int_cst.
	* gcc-interface/decl.c (gnat_to_gnu_entity): Likewise.
	(gnat_to_gnu_entity) <E_Array_Type>: Always translate the index types
	and compute their base type from that.
	<E_Array_Subtype>: Remove duplicate declaration.
	* gcc-interface/misc.c (get_array_bit_stride): Call build_int_cst.
	* gcc-interface/trans.c (get_type_length): Likewise.
	(Attribute_to_gnu): Likewise.
	(Loop_Statement_to_gnu): Likewise.
	(Call_to_gnu): Likewise.
	(gnat_to_gnu): Call build_real, build_int_cst, gnat_unsigned_type_for
	and gnat_signed_type_for.  Minor tweaks.
	(build_binary_op_trapv): Likewise.
	(emit_check): Likewise.
	(convert_with_check): Likewise.
	(Raise_Error_to_gnu): Adjust calls to the build_call_raise family of
	functions.  Minor tweaks.
	(Case_Statement_to_gnu): Remove dead code.
	(gnat_to_gnu): Call gnat_unsigned_type_for and gnat_signed_type_for.
	(init_code_table): Minor reordering.
	* gcc-interface/utils.c (gnat_unsigned_type): Delete.
	(gnat_signed_type): Likewise.
	(gnat_signed_or_unsigned_type_for): New function.
	(unchecked_convert): Use directly the size in the test for precision
	vs size adjustments.
	(install_builtin_elementary_types): Call gnat_signed_type_for.
	* gcc-interface/utils2.c (nonbinary_modular_operation): Call
	build_int_cst.
	(build_goto_raise): New function taken from...
	(build_call_raise): ...here.  Call it.
	(build_call_raise_column): Add KIND parameter and call it.
	(build_call_raise_range): Likewise.

From-SVN: r232503
This commit is contained in:
Eric Botcazou 2016-01-18 11:29:00 +00:00 committed by Eric Botcazou
parent f5460595a4
commit 9a1bdc314b
8 changed files with 207 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
gcc/ada/ChangeLog
View File

@ -1,3 +1,45 @@
2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/gigi.h (build_call_raise_column): Adjust prototype.
(build_call_raise_range): Likewise.
(gnat_unsigned_type): Delete.
(gnat_signed_type): Likewise.
(gnat_signed_or_unsigned_type_for): New prototype.
(gnat_unsigned_type_for): New inline function.
(gnat_signed_type_for): Likewise.
* gcc-interface/cuintp.c (build_cst_from_int): Call build_int_cst.
* gcc-interface/decl.c (gnat_to_gnu_entity): Likewise.
(gnat_to_gnu_entity) <E_Array_Type>: Always translate the index types
and compute their base type from that.
<E_Array_Subtype>: Remove duplicate declaration.
* gcc-interface/misc.c (get_array_bit_stride): Call build_int_cst.
* gcc-interface/trans.c (get_type_length): Likewise.
(Attribute_to_gnu): Likewise.
(Loop_Statement_to_gnu): Likewise.
(Call_to_gnu): Likewise.
(gnat_to_gnu): Call build_real, build_int_cst, gnat_unsigned_type_for
and gnat_signed_type_for. Minor tweaks.
(build_binary_op_trapv): Likewise.
(emit_check): Likewise.
(convert_with_check): Likewise.
(Raise_Error_to_gnu): Adjust calls to the build_call_raise family of
functions. Minor tweaks.
(Case_Statement_to_gnu): Remove dead code.
(gnat_to_gnu): Call gnat_unsigned_type_for and gnat_signed_type_for.
(init_code_table): Minor reordering.
* gcc-interface/utils.c (gnat_unsigned_type): Delete.
(gnat_signed_type): Likewise.
(gnat_signed_or_unsigned_type_for): New function.
(unchecked_convert): Use directly the size in the test for precision
vs size adjustments.
(install_builtin_elementary_types): Call gnat_signed_type_for.
* gcc-interface/utils2.c (nonbinary_modular_operation): Call
build_int_cst.
(build_goto_raise): New function taken from...
(build_call_raise): ...here. Call it.
(build_call_raise_column): Add KIND parameter and call it.
(build_call_raise_range): Likewise.
2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/ada-tree.h (TYPE_IMPLEMENTS_PACKED_ARRAY_P): Rename to

8
gcc/ada/gcc-interface/cuintp.c
View File

@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
* Copyright (C) 1992-2015, Free Software Foundation, Inc. *
* Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* 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- *
@ -52,8 +52,8 @@
the integer value itself. The origin of the Uints_Ptr table is adjusted so
that a Uint value of Uint_Bias indexes the first element.
First define a utility function that operates like build_int_cst_type for
integral types and does a conversion for floating-point types. */
First define a utility function that is build_int_cst for integral types and
does a conversion for floating-point types. */
static tree
build_cst_from_int (tree type, HOST_WIDE_INT low)
@ -61,7 +61,7 @@ build_cst_from_int (tree type, HOST_WIDE_INT low)
if (SCALAR_FLOAT_TYPE_P (type))
return convert (type, build_int_cst (gnat_type_for_size (32, 0), low));
else
return build_int_cst_type (type, low);
return build_int_cst (type, low);
}
/* Similar to UI_To_Int, but return a GCC INTEGER_CST or REAL_CST node,

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

@ -1716,7 +1716,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_MODULAR_P (gnu_type) = 1;
SET_TYPE_MODULUS (gnu_type, gnu_modulus);
gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
convert (gnu_type, integer_one_node));
build_int_cst (gnu_type, 1));
}
/* If the upper bound is not maximal, make an extra subtype. */
@ -2113,8 +2113,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnat_index = Next_Index (gnat_index))
{
char field_name[16];
tree gnu_index_base_type
= get_unpadded_type (Base_Type (Etype (gnat_index)));
tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
tree gnu_index_base_type = get_base_type (gnu_index_type);
tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
tree gnu_min, gnu_max, gnu_high;
@ -2173,7 +2173,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* Update the maximum size of the array in elements. */
if (gnu_max_size)
{
tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
tree gnu_min
= convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
tree gnu_max
@ -2495,8 +2494,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
tree gnu_base_index_base_type
= get_base_type (gnu_base_index_type);
tree gnu_base_base_min
= convert (sizetype,
TYPE_MIN_VALUE (gnu_base_index_base_type));

30
gcc/ada/gcc-interface/gigi.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2015, Free Software Foundation, Inc. *
* Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* 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- *
@ -538,11 +538,9 @@ extern tree gnat_type_for_mode (machine_mode mode, int unsignedp);
/* Perform final processing on global 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);
/* Return the signed version of a TYPE_NODE, a scalar type. */
extern tree gnat_signed_type (tree type_node);
/* Return the signed or unsigned version of TYPE_NODE, a scalar type, the
signedness being specified by UNSIGNEDP. */
extern tree gnat_signed_or_unsigned_type_for (int unsignedp, tree type_node);
/* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
transparently converted to each other. */
@ -898,11 +896,11 @@ extern tree build_call_raise (int msg, Node_Id gnat_node, char kind);
/* Similar to build_call_raise, with extra information about the column
where the check failed. */
extern tree build_call_raise_column (int msg, Node_Id gnat_node);
extern tree build_call_raise_column (int msg, Node_Id gnat_node, char kind);
/* Similar to build_call_raise_column, for an index or range check exception ,
with extra information of the form "INDEX out of range FIRST..LAST". */
extern tree build_call_raise_range (int msg, Node_Id gnat_node,
extern tree build_call_raise_range (int msg, Node_Id gnat_node, char kind,
tree index, tree first, tree last);
/* Return a CONSTRUCTOR of TYPE whose elements are V. This is not the
@ -1120,3 +1118,19 @@ return_type_with_variable_size_p (tree type)
return false;
}
/* Return the unsigned version of TYPE_NODE, a scalar type. */
static inline tree
gnat_unsigned_type_for (tree type_node)
{
return gnat_signed_or_unsigned_type_for (1, type_node);
}
/* Return the signed version of TYPE_NODE, a scalar type. */
static inline tree
gnat_signed_type_for (tree type_node)
{
return gnat_signed_or_unsigned_type_for (0, type_node);
}

6
gcc/ada/gcc-interface/misc.c
View File

@ -1035,7 +1035,7 @@ get_array_bit_stride (tree comp_type)
{
stride = fold_convert (bitsizetype, stride);
stride = build_binary_op (MULT_EXPR, bitsizetype,
stride, build_int_cstu (bitsizetype, 8));
stride, build_int_cst (bitsizetype, 8));
}
for (int i = 0; i < info.ndimensions; ++i)
@ -1053,10 +1053,10 @@ get_array_bit_stride (tree comp_type)
fold_convert (sbitsizetype,
info.dimen[i].lower_bound)),
count = build_binary_op (PLUS_EXPR, sbitsizetype,
count, build_int_cstu (sbitsizetype, 1));
count, build_int_cst (sbitsizetype, 1));
count = build_binary_op (MAX_EXPR, sbitsizetype,
count,
build_int_cstu (sbitsizetype, 0));
build_int_cst (sbitsizetype, 0));
count = fold_convert (bitsizetype, count);
stride = build_binary_op (MULT_EXPR, bitsizetype, stride, count);
}

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

@ -1555,12 +1555,12 @@ get_type_length (tree type, tree result_type)
build_binary_op (MINUS_EXPR, comp_type,
convert (comp_type, hb),
convert (comp_type, lb)),
convert (comp_type, integer_one_node));
build_int_cst (comp_type, 1));
length
= build_cond_expr (result_type,
build_binary_op (GE_EXPR, boolean_type_node, hb, lb),
convert (result_type, length),
convert (result_type, integer_zero_node));
build_int_cst (result_type, 0));
return length;
}
@ -1637,7 +1637,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
gnu_result
= build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
gnu_result_type, gnu_expr,
convert (gnu_result_type, integer_one_node));
build_int_cst (gnu_result_type, 1));
break;
case Attr_Address:
@ -2508,22 +2508,6 @@ Case_Statement_to_gnu (Node_Id gnat_node)
gnu_expr = gnat_to_gnu (Expression (gnat_node));
gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
/* The range of values in a case statement is determined by the rules in
RM 5.4(7-9). In almost all cases, this range is represented by the Etype
of the expression. One exception arises in the case of a simple name that
is parenthesized. This still has the Etype of the name, but since it is
not a name, para 7 does not apply, and we need to go to the base type.
This is the only case where parenthesization affects the dynamic
semantics (i.e. the range of possible values at run time that is covered
by the others alternative).
Another exception is if the subtype of the expression is non-static. In
that case, we also have to use the base type. */
if (Paren_Count (Expression (gnat_node)) != 0
|| !Is_OK_Static_Subtype (Underlying_Type
(Etype (Expression (gnat_node)))))
gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
/* We build a SWITCH_EXPR that contains the code with interspersed
CASE_LABEL_EXPRs for each label. */
if (!Sloc_to_locus (End_Location (gnat_node), &end_locus))
@ -2894,7 +2878,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
Entity_Id gnat_type = Etype (gnat_loop_var);
tree gnu_type = get_unpadded_type (gnat_type);
tree gnu_base_type = get_base_type (gnu_type);
tree gnu_one_node = convert (gnu_base_type, integer_one_node);
tree gnu_one_node = build_int_cst (gnu_base_type, 1);
tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
enum tree_code update_code, test_code, shift_code;
bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
@ -2990,7 +2974,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
gnu_first = convert (gnu_base_type, gnu_first);
gnu_last = convert (gnu_base_type, gnu_last);
gnu_one_node = convert (gnu_base_type, integer_one_node);
gnu_one_node = build_int_cst (gnu_base_type, 1);
use_iv = true;
}
@ -4682,12 +4666,14 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
&& (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
&& TREE_CODE (gnu_size) == INTEGER_CST
&& compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
gnu_actual
= unchecked_convert (DECL_ARG_TYPE (gnu_formal),
convert (gnat_type_for_size
(TREE_INT_CST_LOW (gnu_size), 1),
integer_zero_node),
false);
{
tree type_for_size
= gnat_type_for_size (TREE_INT_CST_LOW (gnu_size), 1);
gnu_actual
= unchecked_convert (DECL_ARG_TYPE (gnu_formal),
build_int_cst (type_for_size, 0),
false);
}
else
gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
}
@ -5497,10 +5483,9 @@ build_noreturn_cond (tree cond)
return build1 (NOP_EXPR, boolean_type_node, t);
}
/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Raise_xxx_Error,
to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where
we should place the result type. LABEL_P is true if there is a label to
branch to for the exception. */
/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
we should place the result type. */
static tree
Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
@ -5514,13 +5499,13 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
&& !get_exception_label (kind);
tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
*gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
/* The following processing is not required for correctness. Its purpose is
to give more precise error messages and to record some information. */
switch (reason)
{
case CE_Access_Check_Failed:
if (with_extra_info)
gnu_result = build_call_raise_column (reason, gnat_node);
gnu_result = build_call_raise_column (reason, gnat_node, kind);
break;
case CE_Index_Check_Failed:
@ -5566,7 +5551,7 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
&& Known_Esize (gnat_type)
&& UI_To_Int (Esize (gnat_type)) <= 32)
gnu_result
= build_call_raise_range (reason, gnat_node, gnu_index,
= build_call_raise_range (reason, gnat_node, kind, gnu_index,
gnu_low_bound, gnu_high_bound);
/* If optimization is enabled and we are inside a loop, we try to
@ -5636,11 +5621,14 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
break;
}
/* The following processing does the common work. */
common:
if (!gnu_result)
gnu_result = build_call_raise (reason, gnat_node, kind);
set_expr_location_from_node (gnu_result, gnat_node);
*gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
/* If the type is VOID, this is a statement, so we need to generate the code
for the call. Handle a condition, if there is one. */
if (VOID_TYPE_P (*gnu_result_type_p))
@ -5864,8 +5852,8 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
else
gnu_result
= build_int_cst_type
(gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
= build_int_cst (gnu_result_type,
UI_To_CC (Char_Literal_Value (gnat_node)));
break;
case N_Real_Literal:
@ -5893,7 +5881,7 @@ gnat_to_gnu (Node_Id gnat_node)
ur_realval, Round_Even, gnat_node);
if (UR_Is_Zero (ur_realval))
gnu_result = convert (gnu_result_type, integer_zero_node);
gnu_result = build_real (gnu_result_type, dconst0);
else
{
REAL_VALUE_TYPE tmp;
@ -6609,7 +6597,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result_type, gnu_lhs, gnu_rhs);
break;
case N_Op_Or: case N_Op_And: case N_Op_Xor:
case N_Op_And:
case N_Op_Or:
case N_Op_Xor:
/* These can either be operations on booleans or on modular types.
Fall through for boolean types since that's the way GNU_CODES is
set up. */
@ -6630,16 +6620,24 @@ gnat_to_gnu (Node_Id gnat_node)
/* ... fall through ... */
case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
case N_Op_Mod: case N_Op_Rem:
case N_Op_Eq:
case N_Op_Ne:
case N_Op_Lt:
case N_Op_Le:
case N_Op_Gt:
case N_Op_Ge:
case N_Op_Add:
case N_Op_Subtract:
case N_Op_Multiply:
case N_Op_Mod:
case N_Op_Rem:
case N_Op_Rotate_Left:
case N_Op_Rotate_Right:
case N_Op_Shift_Left:
case N_Op_Shift_Right:
case N_Op_Shift_Right_Arithmetic:
case N_And_Then: case N_Or_Else:
case N_And_Then:
case N_Or_Else:
{
enum tree_code code = gnu_codes[kind];
bool ignore_lhs_overflow = false;
@ -6682,8 +6680,7 @@ gnat_to_gnu (Node_Id gnat_node)
build_binary_op (MINUS_EXPR,
gnu_count_type,
gnu_max_shift,
convert (gnu_count_type,
integer_one_node)),
build_int_cst (gnu_count_type, 1)),
gnu_rhs);
}
@ -6693,13 +6690,13 @@ gnat_to_gnu (Node_Id gnat_node)
the way down and causes a CE to be explicitly raised. */
if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
{
gnu_type = gnat_unsigned_type (gnu_type);
gnu_type = gnat_unsigned_type_for (gnu_type);
ignore_lhs_overflow = true;
}
else if (kind == N_Op_Shift_Right_Arithmetic
&& TYPE_UNSIGNED (gnu_type))
{
gnu_type = gnat_signed_type (gnu_type);
gnu_type = gnat_signed_type_for (gnu_type);
ignore_lhs_overflow = true;
}
@ -6715,13 +6712,12 @@ gnat_to_gnu (Node_Id gnat_node)
/* Instead of expanding overflow checks for addition, subtraction
and multiplication itself, the front end will leave this to
the back end when Backend_Overflow_Checks_On_Target is set.
As the GCC back end itself does not know yet how to properly
As the back end itself does not know yet how to properly
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
&& (kind == N_Op_Add
|| kind == N_Op_Subtract
|| kind == N_Op_Multiply)
if (Do_Overflow_Check (gnat_node)
&& Backend_Overflow_Checks_On_Target
&& (code == PLUS_EXPR || code == MINUS_EXPR || code == MULT_EXPR)
&& !TYPE_UNSIGNED (gnu_type)
&& !FLOAT_TYPE_P (gnu_type))
gnu_result = build_binary_op_trapv (code, gnu_type,
@ -6746,7 +6742,7 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_rhs,
convert (TREE_TYPE (gnu_rhs),
TYPE_SIZE (gnu_type))),
convert (gnu_type, integer_zero_node),
build_int_cst (gnu_type, 0),
gnu_result);
}
break;
@ -6784,7 +6780,8 @@ gnat_to_gnu (Node_Id gnat_node)
/* ... fall through ... */
case N_Op_Minus: case N_Op_Abs:
case N_Op_Minus:
case N_Op_Abs:
gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
@ -7382,7 +7379,7 @@ gnat_to_gnu (Node_Id gnat_node)
true, true, NULL, gnat_node);
add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr,
convert (ptr_type_node, integer_zero_node)));
build_int_cst (ptr_type_node, 0)));
add_stmt (build_call_n_expr (reraise_zcx_decl, 1, gnu_expr));
gnat_poplevel ();
gnu_result = end_stmt_group ();
@ -8861,7 +8858,7 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
tree rhs = gnat_protect_expr (right);
tree type_max = TYPE_MAX_VALUE (gnu_type);
tree type_min = TYPE_MIN_VALUE (gnu_type);
tree zero = convert (gnu_type, integer_zero_node);
tree zero = build_int_cst (gnu_type, 0);
tree gnu_expr, rhs_lt_zero, tmp1, tmp2;
tree check_pos, check_neg, check;
@ -9151,7 +9148,9 @@ emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
return
fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
convert (TREE_TYPE (gnu_expr), integer_zero_node)),
SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr))
? build_real (TREE_TYPE (gnu_expr), dconst0)
: build_int_cst (TREE_TYPE (gnu_expr), 0)),
gnu_expr);
}
@ -9207,17 +9206,21 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
comparing them properly. Likewise, convert the upper bounds
to unsigned types. */
if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
gnu_in_lb
= convert (gnat_signed_type_for (gnu_in_basetype), gnu_in_lb);
if (INTEGRAL_TYPE_P (gnu_in_basetype)
&& !TYPE_UNSIGNED (gnu_in_basetype))
gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
gnu_in_ub
= convert (gnat_unsigned_type_for (gnu_in_basetype), gnu_in_ub);
if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
gnu_out_lb
= convert (gnat_signed_type_for (gnu_base_type), gnu_out_lb);
if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
gnu_out_ub
= convert (gnat_unsigned_type_for (gnu_base_type), gnu_out_ub);
/* Check each bound separately and only if the result bound
is tighter than the bound on the input type. Note that all the
@ -9301,7 +9304,7 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
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_zero = build_real (gnu_in_basetype, dconst0);
gnu_result = gnat_protect_expr (gnu_result);
gnu_conv = convert (calc_type, gnu_result);
gnu_comp
@ -10122,9 +10125,6 @@ get_elaboration_procedure (void)
static void
init_code_table (void)
{
gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
@ -10147,6 +10147,8 @@ init_code_table (void)
gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
}
#include "gt-ada-trans.h"

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

@ -3354,35 +3354,13 @@ gnat_type_for_mode (machine_mode mode, int unsignedp)
return NULL_TREE;
}
/* Return the unsigned version of a TYPE_NODE, a scalar type. */
/* Return the signed or unsigned version of TYPE_NODE, a scalar type, the
signedness being specified by UNSIGNEDP. */
tree
gnat_unsigned_type (tree type_node)
gnat_signed_or_unsigned_type_for (int unsignedp, tree type_node)
{
tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
{
type = copy_node (type);
TREE_TYPE (type) = type_node;
}
else if (TREE_TYPE (type_node)
&& TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
&& TYPE_MODULAR_P (TREE_TYPE (type_node)))
{
type = copy_node (type);
TREE_TYPE (type) = TREE_TYPE (type_node);
}
return type;
}
/* Return the signed version of a TYPE_NODE, a scalar type. */
tree
gnat_signed_type (tree type_node)
{
tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
tree type = gnat_type_for_size (TYPE_PRECISION (type_node), unsignedp);
if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
{
@ -4936,8 +4914,8 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
are no considerations of precision or size involved. */
else if (INTEGRAL_TYPE_P (type)
&& TYPE_RM_SIZE (type)
&& (0 != compare_tree_int (TYPE_RM_SIZE (type),
GET_MODE_BITSIZE (TYPE_MODE (type)))
&& (tree_int_cst_compare (TYPE_RM_SIZE (type),
TYPE_SIZE (type)) < 0
|| (AGGREGATE_TYPE_P (etype)
&& TYPE_REVERSE_STORAGE_ORDER (etype))))
{
@ -4973,8 +4951,8 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
type with reverse storage order and we also proceed similarly. */
else if (INTEGRAL_TYPE_P (etype)
&& TYPE_RM_SIZE (etype)
&& (0 != compare_tree_int (TYPE_RM_SIZE (etype),
GET_MODE_BITSIZE (TYPE_MODE (etype)))
&& (tree_int_cst_compare (TYPE_RM_SIZE (etype),
TYPE_SIZE (etype)) < 0
|| (AGGREGATE_TYPE_P (type)
&& TYPE_REVERSE_STORAGE_ORDER (type))))
{
@ -5094,26 +5072,25 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
is an integral type of the same precision and signedness or if the output
is a biased type or if both the input and output are unsigned. */
if (!notrunc_p
&& INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
&& !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
&& 0 != compare_tree_int (TYPE_RM_SIZE (type),
GET_MODE_BITSIZE (TYPE_MODE (type)))
&& INTEGRAL_TYPE_P (type)
&& TYPE_RM_SIZE (type)
&& tree_int_cst_compare (TYPE_RM_SIZE (type), TYPE_SIZE (type)) < 0
&& !(INTEGRAL_TYPE_P (etype)
&& TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype)
&& operand_equal_p (TYPE_RM_SIZE (type),
(TYPE_RM_SIZE (etype) != 0
? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
0))
&& tree_int_cst_compare (TYPE_RM_SIZE (type),
TYPE_RM_SIZE (etype)
? TYPE_RM_SIZE (etype)
: TYPE_SIZE (etype)) == 0)
&& !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
&& !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype)))
{
tree base_type
= gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type));
= gnat_type_for_size (TREE_INT_CST_LOW (TYPE_SIZE (type)),
TYPE_UNSIGNED (type));
tree shift_expr
= convert (base_type,
size_binop (MINUS_EXPR,
bitsize_int
(GET_MODE_BITSIZE (TYPE_MODE (type))),
TYPE_RM_SIZE (type)));
TYPE_SIZE (type), TYPE_RM_SIZE (type)));
expr
= convert (type,
build_binary_op (RSHIFT_EXPR, base_type,
@ -5434,7 +5411,7 @@ builtin_type_for_size (int size, bool unsignedp)
static void
install_builtin_elementary_types (void)
{
signed_size_type_node = gnat_signed_type (size_type_node);
signed_size_type_node = gnat_signed_type_for (size_type_node);
pid_type_node = integer_type_node;
void_list_node = build_void_list_node ();

76
gcc/ada/gcc-interface/utils2.c
View File

@ -592,7 +592,7 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
result = gnat_protect_expr (result);
result = fold_build3 (COND_EXPR, op_type,
fold_build2 (LT_EXPR, boolean_type_node, result,
convert (op_type, integer_zero_node)),
build_int_cst (op_type, 0)),
fold_build2 (PLUS_EXPR, op_type, result, modulus),
result);
}
@ -1601,8 +1601,8 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand)
{
if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type,
modulus,
convert (operation_type,
integer_one_node))))
build_int_cst (operation_type,
1))))
result = fold_build2 (BIT_XOR_EXPR, operation_type,
operand, modulus);
else
@ -1613,9 +1613,8 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand)
fold_build2 (NE_EXPR,
boolean_type_node,
operand,
convert
(operation_type,
integer_zero_node)),
build_int_cst
(operation_type, 0)),
result, operand);
}
else
@ -1626,8 +1625,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand)
that constant for nonbinary modulus. */
tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus,
convert (operation_type,
integer_one_node));
build_int_cst (operation_type, 1));
if (mod_pow2)
result = fold_build2 (BIT_XOR_EXPR, operation_type,
@ -1748,6 +1746,32 @@ build_call_n_expr (tree fndecl, int n, ...)
return fn;
}
/* Build a goto to LABEL for a raise, with an optional call to Local_Raise.
MSG gives the exception's identity for the call to Local_Raise, if any. */
static tree
build_goto_raise (tree label, int msg)
{
tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
/* If Local_Raise is present, build Local_Raise (Exception'Identity). */
if (Present (local_raise))
{
tree gnu_local_raise = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
tree gnu_exception_entity
= gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
tree gnu_call
= build_call_n_expr (gnu_local_raise, 1,
build_unary_op (ADDR_EXPR, NULL_TREE,
gnu_exception_entity));
gnu_result
= build2 (COMPOUND_EXPR, void_type_node, gnu_call, gnu_result);
}
return gnu_result;
}
/* Expand the SLOC of GNAT_NODE, if present, into tree location information
pointed to by FILENAME, LINE and COL. Fall back to the current location
if GNAT_NODE is absent or has no SLOC. */
@ -1803,27 +1827,7 @@ build_call_raise (int msg, Node_Id gnat_node, char kind)
/* If this is to be done as a goto, handle that case. */
if (label)
{
Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
/* If Local_Raise is present, build Local_Raise (Exception'Identity). */
if (Present (local_raise))
{
tree gnu_local_raise
= gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
tree gnu_exception_entity
= gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
tree gnu_call
= build_call_n_expr (gnu_local_raise, 1,
build_unary_op (ADDR_EXPR, NULL_TREE,
gnu_exception_entity));
gnu_result
= build2 (COMPOUND_EXPR, void_type_node, gnu_call, gnu_result);
}
return gnu_result;
}
return build_goto_raise (label, msg);
expand_sloc (gnat_node, &filename, &line, NULL);
@ -1839,11 +1843,16 @@ build_call_raise (int msg, Node_Id gnat_node, char kind)
where the check failed. */
tree
build_call_raise_column (int msg, Node_Id gnat_node)
build_call_raise_column (int msg, Node_Id gnat_node, char kind)
{
tree fndecl = gnat_raise_decls_ext[msg];
tree label = get_exception_label (kind);
tree filename, line, col;
/* If this is to be done as a goto, handle that case. */
if (label)
return build_goto_raise (label, msg);
expand_sloc (gnat_node, &filename, &line, &col);
return
@ -1858,12 +1867,17 @@ build_call_raise_column (int msg, Node_Id gnat_node)
with extra information of the form "INDEX out of range FIRST..LAST". */
tree
build_call_raise_range (int msg, Node_Id gnat_node,
build_call_raise_range (int msg, Node_Id gnat_node, char kind,
tree index, tree first, tree last)
{
tree fndecl = gnat_raise_decls_ext[msg];
tree label = get_exception_label (kind);
tree filename, line, col;
/* If this is to be done as a goto, handle that case. */
if (label)
return build_goto_raise (label, msg);
expand_sloc (gnat_node, &filename, &line, &col);
return