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

exp_ch2.adb (Expand_Current_Value): Make an appropriate character literal if the entity is of a character type. 

* exp_ch2.adb (Expand_Current_Value): Make an appropriate character
	literal if the entity is of a character type.
	* gcc-interface/lang.opt (fsigned-char): New option.
	* gcc-interface/misc.c (gnat_handle_option): Accept it.
	(gnat_init): Adjust comment.
	* gcc-interface/gigi.h (finish_character_type): New prototype.
	(maybe_character_type): New inline function.
	(maybe_character_value): Likewise.
	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Enumeration_Type>: For
	a character of CHAR_TYPE_SIZE, make a signed type if flag_signed_char.
	Set TYPE_ARTIFICIAL early and call finish_character_type on the type.
	<E_Enumeration_Subtype>: For a subtype of character with RM_Size and
	Esize equal to CHAR_TYPE_SIZE, make a signed type if flag_signed_char.
	Copy TYPE_STRING_FLAG from type to subtype.
	<E_Array_Type>: Deal with character index types.
	<E_Array_Subtype>: Likewise.
	* gcc-interface/trans.c (gigi): Replace unsigned_char_type_node with
	char_type_node throughout.
	(build_raise_check): Likewise.
	(get_type_length): Deal with character types.
	(Attribute_to_gnu) <Attr_Pos>: Likewise.  Remove obsolete range check
	code.  Minor tweak.
	<Attr_Pred>: Likewise.
	(Loop_Statement_to_gnu): Likewise.
	(Raise_Error_to_gnu): Likewise.
	<N_Indexed_Component>: Deal with character index types.  Remove
	obsolete code.
	<N_Slice>: Likewise.
	<N_Type_Conversion>: Deal with character types.  Minor tweak.
	<N_Unchecked_Type_Conversion>: Likewise.
	<N_In>: Likewise.
	<N_Op_Eq>: Likewise.
	(emit_index_check): Delete.
	* gcc-interface/utils.c (finish_character_type): New function.
	(gnat_signed_or_unsigned_type_for): Deal with built-in character types.
	* gcc-interface/utils2.c (expand_sloc): Replace unsigned_char_type_node
	with char_type_node.
	(build_call_raise): Likewise.
	(build_call_raise_column): Likewise.
	(build_call_raise_range): Likewise.

From-SVN: r232604
This commit is contained in:
Eric Botcazou 2016-01-20 09:01:34 +00:00 committed by Eric Botcazou
parent dd6f2cf98c
commit 825da0d20f
9 changed files with 237 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gcc/ada/ChangeLog
View File

@ -1,3 +1,46 @@
2016-01-20 Eric Botcazou <ebotcazou@adacore.com>
* exp_ch2.adb (Expand_Current_Value): Make an appropriate character
literal if the entity is of a character type.
* gcc-interface/lang.opt (fsigned-char): New option.
* gcc-interface/misc.c (gnat_handle_option): Accept it.
(gnat_init): Adjust comment.
* gcc-interface/gigi.h (finish_character_type): New prototype.
(maybe_character_type): New inline function.
(maybe_character_value): Likewise.
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Enumeration_Type>: For
a character of CHAR_TYPE_SIZE, make a signed type if flag_signed_char.
Set TYPE_ARTIFICIAL early and call finish_character_type on the type.
<E_Enumeration_Subtype>: For a subtype of character with RM_Size and
Esize equal to CHAR_TYPE_SIZE, make a signed type if flag_signed_char.
Copy TYPE_STRING_FLAG from type to subtype.
<E_Array_Type>: Deal with character index types.
<E_Array_Subtype>: Likewise.
* gcc-interface/trans.c (gigi): Replace unsigned_char_type_node with
char_type_node throughout.
(build_raise_check): Likewise.
(get_type_length): Deal with character types.
(Attribute_to_gnu) <Attr_Pos>: Likewise. Remove obsolete range check
code. Minor tweak.
<Attr_Pred>: Likewise.
(Loop_Statement_to_gnu): Likewise.
(Raise_Error_to_gnu): Likewise.
<N_Indexed_Component>: Deal with character index types. Remove
obsolete code.
<N_Slice>: Likewise.
<N_Type_Conversion>: Deal with character types. Minor tweak.
<N_Unchecked_Type_Conversion>: Likewise.
<N_In>: Likewise.
<N_Op_Eq>: Likewise.
(emit_index_check): Delete.
* gcc-interface/utils.c (finish_character_type): New function.
(gnat_signed_or_unsigned_type_for): Deal with built-in character types.
* gcc-interface/utils2.c (expand_sloc): Replace unsigned_char_type_node
with char_type_node.
(build_call_raise): Likewise.
(build_call_raise_column): Likewise.
(build_call_raise_range): Likewise.
2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/gigi.h (build_call_raise_column): Adjust prototype.

13
gcc/ada/exp_ch2.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- 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- --
@ -193,7 +193,16 @@ package body Exp_Ch2 is
Unchecked_Convert_To (T,
New_Occurrence_Of (Entity (Val), Loc)));
-- If constant is of an integer type, just make an appropriately
-- If constant is of a character type, just make an appropriate
-- character literal, which will get the proper type.
elsif Is_Character_Type (T) then
Rewrite (N,
Make_Character_Literal (Loc,
Chars => Chars (Val),
Char_Literal_Value => Expr_Rep_Value (Val)));
-- If constant is of an integer type, just make an appropriate
-- integer literal, which will get the proper type.
elsif Is_Integer_Type (T) then

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

@ -1560,16 +1560,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
case E_Enumeration_Type:
/* A special case: for the types Character and Wide_Character in
Standard, we do not list all the literals. So if the literals
are not specified, make this an unsigned integer type. */
are not specified, make this an integer type. */
if (No (First_Literal (gnat_entity)))
{
gnu_type = make_unsigned_type (esize);
if (esize == CHAR_TYPE_SIZE && flag_signed_char)
gnu_type = make_signed_type (CHAR_TYPE_SIZE);
else
gnu_type = make_unsigned_type (esize);
TYPE_NAME (gnu_type) = gnu_entity_name;
/* Set TYPE_STRING_FLAG for Character and Wide_Character types.
This is needed by the DWARF-2 back-end to distinguish between
unsigned integer types and character types. */
TYPE_STRING_FLAG (gnu_type) = 1;
/* This flag is needed by the call just below. */
TYPE_ARTIFICIAL (gnu_type) = artificial_p;
finish_character_type (gnu_type);
}
else
{
@ -1765,12 +1773,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
esize = UI_To_Int (RM_Size (gnat_entity));
/* This should be an unsigned type if the base type is unsigned or
/* First subtypes of Character are treated as Character; otherwise
this should be an unsigned type if the base type is unsigned or
if the lower bound is constant and non-negative or if the type
is biased. */
if (Is_Unsigned_Type (Etype (gnat_entity))
|| Is_Unsigned_Type (gnat_entity)
|| Has_Biased_Representation (gnat_entity))
if (kind == E_Enumeration_Subtype
&& No (First_Literal (Etype (gnat_entity)))
&& Esize (gnat_entity) == RM_Size (gnat_entity)
&& esize == CHAR_TYPE_SIZE
&& flag_signed_char)
gnu_type = make_signed_type (CHAR_TYPE_SIZE);
else if (Is_Unsigned_Type (Etype (gnat_entity))
|| Is_Unsigned_Type (gnat_entity)
|| Has_Biased_Representation (gnat_entity))
gnu_type = make_unsigned_type (esize);
else
gnu_type = make_signed_type (esize);
@ -1789,6 +1804,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_BIASED_REPRESENTATION_P (gnu_type)
= Has_Biased_Representation (gnat_entity);
/* Set TYPE_STRING_FLAG for Character and Wide_Character subtypes. */
TYPE_STRING_FLAG (gnu_type) = TYPE_STRING_FLAG (TREE_TYPE (gnu_type));
/* Inherit our alias set from what we're a subtype of. Subtypes
are not different types and a pointer can designate any instance
within a subtype hierarchy. */
@ -2114,7 +2132,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
char field_name[16];
tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
tree gnu_index_base_type = get_base_type (gnu_index_type);
tree gnu_index_base_type
= maybe_character_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;
@ -2363,7 +2382,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnat_base_index = Next_Index (gnat_base_index))
{
tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
tree gnu_index_base_type = get_base_type (gnu_index_type);
tree gnu_index_base_type
= maybe_character_type (get_base_type (gnu_index_type));
tree gnu_orig_min
= convert (gnu_index_base_type,
TYPE_MIN_VALUE (gnu_index_type));
@ -2375,7 +2395,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
tree gnu_base_index_type
= get_unpadded_type (Etype (gnat_base_index));
tree gnu_base_index_base_type
= get_base_type (gnu_base_index_type);
= maybe_character_type (get_base_type (gnu_base_index_type));
tree gnu_base_orig_min
= convert (gnu_base_index_base_type,
TYPE_MIN_VALUE (gnu_base_index_type));

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

@ -604,6 +604,9 @@ extern void build_dummy_unc_pointer_types (Entity_Id gnat_desig_type,
extern void record_builtin_type (const char *name, tree type,
bool artificial_p);
/* Finish constructing the character type CHAR_TYPE. */
extern void finish_character_type (tree char_type);
/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
finish constructing the record type as a fat pointer type. */
extern void finish_fat_pointer_type (tree record_type, tree field_list);
@ -1134,3 +1137,30 @@ gnat_signed_type_for (tree type_node)
{
return gnat_signed_or_unsigned_type_for (0, type_node);
}
/* Adjust the character type TYPE if need be. */
static inline tree
maybe_character_type (tree type)
{
if (TYPE_STRING_FLAG (type) && !TYPE_UNSIGNED (type))
type = gnat_unsigned_type_for (type);
return type;
}
/* Adjust the character value EXPR if need be. */
static inline tree
maybe_character_value (tree expr)
{
tree type = TREE_TYPE (expr);
if (TYPE_STRING_FLAG (type) && !TYPE_UNSIGNED (type))
{
type = gnat_unsigned_type_for (type);
expr = convert (type, expr);
}
return expr;
}

4
gcc/ada/gcc-interface/lang.opt
View File

@ -76,6 +76,10 @@ fshort-enums
Ada AdaWhy AdaSCIL
Use the narrowest integer type possible for enumeration types.
fsigned-char
Ada AdaWhy AdaSCIL
Make \"char\" signed by default.
gant
Ada AdaWhy AdaSCIL Joined Undocumented
Catch typos.

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

@ -169,7 +169,8 @@ gnat_handle_option (size_t scode, const char *arg, int value, int kind,
break;
case OPT_fshort_enums:
/* This is handled by the middle-end. */
case OPT_fsigned_char:
/* These are handled by the middle-end. */
break;
case OPT_fbuiltin_printf:
@ -353,8 +354,7 @@ static bool
gnat_init (void)
{
/* Do little here, most of the standard declarations are set up after the
front-end has been run. Use the same `char' as C, this doesn't really
matter since we'll use the explicit `unsigned char' for Character. */
front-end has been run. Use the same `char' as C for Interfaces.C. */
build_common_tree_nodes (flag_signed_char, false);
/* In Ada, we use an unsigned 8-bit type for the default boolean type. */

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

@ -231,7 +231,6 @@ static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
static tree emit_range_check (tree, Node_Id, Node_Id);
static tree emit_index_check (tree, tree, tree, tree, Node_Id);
static tree emit_check (tree, tree, int, Node_Id);
static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
@ -354,7 +353,7 @@ gigi (Node_Id gnat_root,
/* Record the builtin types. Define `integer' and `character' first so that
dbx will output them first. */
record_builtin_type ("integer", integer_type_node, false);
record_builtin_type ("character", unsigned_char_type_node, false);
record_builtin_type ("character", char_type_node, false);
record_builtin_type ("boolean", boolean_type_node, false);
record_builtin_type ("void", void_type_node, false);
@ -364,8 +363,9 @@ gigi (Node_Id gnat_root,
false);
/* Likewise for character as the type for Standard.Character. */
finish_character_type (char_type_node);
save_gnu_tree (Base_Type (standard_character),
TYPE_NAME (unsigned_char_type_node),
TYPE_NAME (char_type_node),
false);
/* Likewise for boolean as the type for Standard.Boolean. */
@ -544,21 +544,21 @@ gigi (Node_Id gnat_root,
others_decl
= create_var_decl (get_identifier ("OTHERS"),
get_identifier ("__gnat_others_value"),
unsigned_char_type_node, NULL_TREE,
char_type_node, NULL_TREE,
true, false, true, false, false, true, false,
NULL, Empty);
all_others_decl
= create_var_decl (get_identifier ("ALL_OTHERS"),
get_identifier ("__gnat_all_others_value"),
unsigned_char_type_node, NULL_TREE,
char_type_node, NULL_TREE,
true, false, true, false, false, true, false,
NULL, Empty);
unhandled_others_decl
= create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
get_identifier ("__gnat_unhandled_others_value"),
unsigned_char_type_node, NULL_TREE,
char_type_node, NULL_TREE,
true, false, true, false, false, true, false,
NULL, Empty);
@ -571,8 +571,7 @@ gigi (Node_Id gnat_root,
= create_subprog_decl
(get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
build_function_type_list (void_type_node,
build_pointer_type
(unsigned_char_type_node),
build_pointer_type (char_type_node),
integer_type_node, NULL_TREE),
NULL_TREE, is_disabled, false, true, true, true, true, false,
NULL, Empty);
@ -720,8 +719,7 @@ build_raise_check (int check, enum exception_info_kind kind)
Name_Buffer[Name_Len] = 0;
ftype
= build_function_type_list (void_type_node,
build_pointer_type
(unsigned_char_type_node),
build_pointer_type (char_type_node),
integer_type_node, NULL_TREE);
}
else
@ -732,8 +730,7 @@ build_raise_check (int check, enum exception_info_kind kind)
Name_Buffer[Name_Len + 4] = 0;
ftype
= build_function_type_list (void_type_node,
build_pointer_type
(unsigned_char_type_node),
build_pointer_type (char_type_node),
integer_type_node, integer_type_node,
t, t, NULL_TREE);
}
@ -1547,7 +1544,7 @@ static tree
get_type_length (tree type, tree result_type)
{
tree comp_type = get_base_type (result_type);
tree base_type = get_base_type (type);
tree base_type = maybe_character_type (get_base_type (type));
tree lb = convert (base_type, TYPE_MIN_VALUE (type));
tree hb = convert (base_type, TYPE_MAX_VALUE (type));
tree length
@ -1605,13 +1602,11 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
case Attr_Val:
/* 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,
checkp, checkp, true, gnat_node);
}
gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
if (attribute == Attr_Pos)
gnu_expr = maybe_character_value (gnu_expr);
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = convert (gnu_result_type, gnu_expr);
break;
case Attr_Pred:
@ -1620,24 +1615,12 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
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));
if (Do_Range_Check (First (Expressions (gnat_node))))
{
gnu_expr = gnat_protect_expr (gnu_expr);
gnu_expr
= emit_check
(build_binary_op (EQ_EXPR, boolean_type_node,
gnu_expr,
attribute == Attr_Pred
? TYPE_MIN_VALUE (gnu_result_type)
: TYPE_MAX_VALUE (gnu_result_type)),
gnu_expr, CE_Range_Check_Failed, gnat_node);
}
gnu_type = maybe_character_type (gnu_result_type);
if (TREE_TYPE (gnu_expr) != gnu_type)
gnu_expr = convert (gnu_type, gnu_expr);
gnu_result
= build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
gnu_result_type, gnu_expr,
build_int_cst (gnu_result_type, 1));
gnu_type, gnu_expr, build_int_cst (gnu_type, 1));
break;
case Attr_Address:
@ -2877,7 +2860,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
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_base_type = maybe_character_type (get_base_type (gnu_type));
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;
@ -5514,7 +5497,7 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
{
Node_Id gnat_range, gnat_index, gnat_type;
tree gnu_index, gnu_low_bound, gnu_high_bound, disp;
tree gnu_type, gnu_index, gnu_low_bound, gnu_high_bound, disp;
bool neg_p;
struct loop_info_d *loop;
@ -5543,8 +5526,18 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
gnat_type = Etype (gnat_index);
gnu_type = maybe_character_type (get_unpadded_type (gnat_type));
gnu_index = gnat_to_gnu (gnat_index);
if (TREE_TYPE (gnu_index) != gnu_type)
{
if (gnu_low_bound)
gnu_low_bound = convert (gnu_type, gnu_low_bound);
if (gnu_high_bound)
gnu_high_bound = convert (gnu_type, gnu_high_bound);
gnu_index = convert (gnu_type, gnu_index);
}
if (with_extra_info
&& gnu_low_bound
&& gnu_high_bound
@ -5589,7 +5582,7 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
rci->high_bound = gnu_high_bound;
rci->disp = disp;
rci->neg_p = neg_p;
rci->type = get_unpadded_type (gnat_type);
rci->type = gnu_type;
rci->inserted_cond
= build1 (SAVE_EXPR, boolean_type_node, boolean_true_node);
vec_safe_push (loop->checks, rci);
@ -6156,8 +6149,6 @@ gnat_to_gnu (Node_Id gnat_node)
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
gnu_array_object);
gnu_result = gnu_array_object;
/* The failure of this assertion will very likely come from a missing
expansion for a packed array access. */
gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
@ -6184,23 +6175,18 @@ gnat_to_gnu (Node_Id gnat_node)
i++, gnat_temp = Next (gnat_temp))
gnat_expr_array[i] = gnat_temp;
/* Start with the prefix and build the successive references. */
gnu_result = gnu_array_object;
for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
i < ndim;
i++, gnu_type = TREE_TYPE (gnu_type))
{
gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
gnat_temp = gnat_expr_array[i];
gnu_expr = gnat_to_gnu (gnat_temp);
gnu_expr = maybe_character_value (gnat_to_gnu (gnat_temp));
struct loop_info_d *loop;
if (Do_Range_Check (gnat_temp))
gnu_expr
= emit_index_check
(gnu_array_object, gnu_expr,
TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
gnat_temp);
gnu_result
= build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
@ -6251,88 +6237,25 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Slice:
{
Node_Id gnat_range_node = Discrete_Range (gnat_node);
tree gnu_type;
tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
gnu_result = gnat_to_gnu (Prefix (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* Do any implicit dereferences of the prefix and do any needed
range check. */
gnu_result = maybe_implicit_deref (gnu_result);
gnu_result = maybe_unconstrained_array (gnu_result);
gnu_type = TREE_TYPE (gnu_result);
if (Do_Range_Check (gnat_range_node))
{
/* Get the bounds of the slice. */
tree gnu_index_type
= TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
/* Get the permitted bounds. */
tree gnu_base_index_type
= TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
(TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
(TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
gnu_array_object = maybe_implicit_deref (gnu_array_object);
gnu_array_object = maybe_unconstrained_array (gnu_array_object);
gnu_min_expr = gnat_protect_expr (gnu_min_expr);
gnu_max_expr = gnat_protect_expr (gnu_max_expr);
/* Derive a good type to convert everything to. */
gnu_expr_type = get_base_type (gnu_index_type);
/* Test whether the minimum slice value is too small. */
gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
convert (gnu_expr_type,
gnu_min_expr),
convert (gnu_expr_type,
gnu_base_min_expr));
/* Test whether the maximum slice value is too large. */
gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
convert (gnu_expr_type,
gnu_max_expr),
convert (gnu_expr_type,
gnu_base_max_expr));
/* Build a slice index check that returns the low bound,
assuming the slice is not empty. */
gnu_expr = emit_check
(build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
gnu_expr_l, gnu_expr_h),
gnu_min_expr, CE_Index_Check_Failed, gnat_node);
/* Build a conditional expression that does the index checks and
returns the low bound if the slice is not empty (max >= min),
and returns the naked low bound otherwise (max < min), unless
it is non-constant and the high bound is; this prevents VRP
from inferring bogus ranges on the unlikely path. */
gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
build_binary_op (GE_EXPR, gnu_expr_type,
convert (gnu_expr_type,
gnu_max_expr),
convert (gnu_expr_type,
gnu_min_expr)),
gnu_expr,
TREE_CODE (gnu_min_expr) != INTEGER_CST
&& TREE_CODE (gnu_max_expr) == INTEGER_CST
? gnu_max_expr : gnu_min_expr);
}
else
/* Simply return the naked low bound. */
gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
gnu_expr = maybe_character_value (gnu_expr);
/* If this is a slice with non-constant size of an array with constant
size, set the maximum size for the allocation of temporaries. */
if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
&& TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
&& TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object))))
TYPE_ARRAY_MAX_SIZE (gnu_result_type)
= TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object));
gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
gnu_result, gnu_expr);
gnu_array_object, gnu_expr);
}
break;
@ -6472,8 +6395,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Type_Conversion:
case N_Qualified_Expression:
/* Get the operand expression. */
gnu_result = gnat_to_gnu (Expression (gnat_node));
gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* If this is a qualified expression for a tagged type, we mark the type
@ -6484,7 +6406,7 @@ gnat_to_gnu (Node_Id gnat_node)
used_types_insert (gnu_result_type);
gnu_result
= convert_with_check (Etype (gnat_node), gnu_result,
= convert_with_check (Etype (gnat_node), gnu_expr,
Do_Overflow_Check (gnat_node),
Do_Range_Check (Expression (gnat_node)),
kind == N_Type_Conversion
@ -6492,11 +6414,12 @@ gnat_to_gnu (Node_Id gnat_node)
break;
case N_Unchecked_Type_Conversion:
gnu_result = gnat_to_gnu (Expression (gnat_node));
gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
/* Skip further processing if the conversion is deemed a no-op. */
if (unchecked_conversion_nop (gnat_node))
{
gnu_result = gnu_expr;
gnu_result_type = TREE_TYPE (gnu_result);
break;
}
@ -6508,7 +6431,7 @@ gnat_to_gnu (Node_Id gnat_node)
if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
&& IN (Ekind (Etype (gnat_node)), Access_Kind))
{
unsigned int align = known_alignment (gnu_result);
unsigned int align = known_alignment (gnu_expr);
tree gnu_obj_type = TREE_TYPE (gnu_result_type);
unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
@ -6522,11 +6445,11 @@ gnat_to_gnu (Node_Id gnat_node)
/* If we are converting a descriptor to a function pointer, first
build the pointer. */
if (TARGET_VTABLE_USES_DESCRIPTORS
&& TREE_TYPE (gnu_result) == fdesc_type_node
&& TREE_TYPE (gnu_expr) == fdesc_type_node
&& POINTER_TYPE_P (gnu_result_type))
gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
gnu_result = unchecked_convert (gnu_result_type, gnu_result,
gnu_result = unchecked_convert (gnu_result_type, gnu_expr,
No_Truncation (gnat_node));
break;
@ -6560,6 +6483,14 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_obj));
if (TREE_TYPE (gnu_obj) != gnu_op_type)
{
gnu_obj = convert (gnu_op_type, gnu_obj);
gnu_low = convert (gnu_op_type, gnu_low);
gnu_high = convert (gnu_op_type, gnu_high);
}
/* If LOW and HIGH are identical, perform an equality test. Otherwise,
ensure that GNU_OBJ is evaluated only once and perform a full range
test. */
@ -6660,6 +6591,13 @@ gnat_to_gnu (Node_Id gnat_node)
{
gnu_lhs = maybe_unconstrained_array (gnu_lhs);
gnu_rhs = maybe_unconstrained_array (gnu_rhs);
tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_lhs));
if (TREE_TYPE (gnu_lhs) != gnu_op_type)
{
gnu_lhs = convert (gnu_op_type, gnu_lhs);
gnu_rhs = convert (gnu_op_type, gnu_rhs);
}
}
/* If this is a shift whose count is not guaranteed to be correct,
@ -9081,49 +9019,6 @@ emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
gnu_expr, CE_Range_Check_Failed, gnat_node);
}
/* 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. GNAT_NODE is the GNAT node conveying the source
location for which the error should be signaled. */
static tree
emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
tree gnu_high, Node_Id gnat_node)
{
tree gnu_expr_check;
/* Checked expressions must be evaluated only once. */
gnu_expr = gnat_protect_expr (gnu_expr);
/* Must do this computation in the base type in case the expression's
type is an unsigned subtypes. */
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. */
gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
return emit_check
(build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
build_binary_op (LT_EXPR, boolean_type_node,
gnu_expr_check,
convert (TREE_TYPE (gnu_expr_check),
gnu_low)),
build_binary_op (GT_EXPR, boolean_type_node,
gnu_expr_check,
convert (TREE_TYPE (gnu_expr_check),
gnu_high))),
gnu_expr, CE_Index_Check_Failed, gnat_node);
}
/* GNU_COND contains the condition corresponding to an index, overflow or
range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.

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

@ -1595,6 +1595,48 @@ record_builtin_type (const char *name, tree type, bool artificial_p)
debug_hooks->type_decl (type_decl, false);
}
/* Finish constructing the character type CHAR_TYPE.
In Ada character types are enumeration types and, as a consequence, are
represented in the front-end by integral types holding the positions of
the enumeration values as defined by the language, which means that the
integral types are unsigned.
Unfortunately the signedness of 'char' in C is implementation-defined
and GCC even has the option -fsigned-char to toggle it at run time.
Since GNAT's philosophy is to be compatible with C by default, to wit
Interfaces.C.char is defined as a mere copy of Character, we may need
to declare character types as signed types in GENERIC and generate the
necessary adjustments to make them behave as unsigned types.
The overall strategy is as follows: if 'char' is unsigned, do nothing;
if 'char' is signed, translate character types of CHAR_TYPE_SIZE and
character subtypes with RM_Size = Esize = CHAR_TYPE_SIZE into signed
types. The idea is to ensure that the bit pattern contained in the
Esize'd objects is not changed, even though the numerical value will
be interpreted differently depending on the signedness.
For character types, the bounds are implicit and, therefore, need to
be adjusted. Morever, the debug info needs the unsigned version. */
void
finish_character_type (tree char_type)
{
if (TYPE_UNSIGNED (char_type))
return;
/* Make a copy of the unsigned version since we'll modify it below. */
tree unsigned_char_type = copy_type (gnat_unsigned_type_for (char_type));
TYPE_NAME (unsigned_char_type) = TYPE_NAME (char_type);
TYPE_STRING_FLAG (unsigned_char_type) = TYPE_STRING_FLAG (char_type);
TYPE_ARTIFICIAL (unsigned_char_type) = TYPE_ARTIFICIAL (char_type);
SET_TYPE_DEBUG_TYPE (char_type, unsigned_char_type);
SET_TYPE_RM_MIN_VALUE (char_type, TYPE_MIN_VALUE (unsigned_char_type));
SET_TYPE_RM_MAX_VALUE (char_type, TYPE_MAX_VALUE (unsigned_char_type));
}
/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
finish constructing the record type as a fat pointer type. */
@ -3360,6 +3402,9 @@ gnat_type_for_mode (machine_mode mode, int unsignedp)
tree
gnat_signed_or_unsigned_type_for (int unsignedp, tree type_node)
{
if (type_node == char_type_node)
return unsignedp ? unsigned_char_type_node : signed_char_type_node;
tree type = gnat_type_for_size (TYPE_PRECISION (type_node), unsignedp);
if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))

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

@ -1804,7 +1804,7 @@ expand_sloc (Node_Id gnat_node, tree *filename, tree *line, tree *col)
const int len = strlen (str);
*filename = build_string (len, str);
TREE_TYPE (*filename) = build_array_type (unsigned_char_type_node,
TREE_TYPE (*filename) = build_array_type (char_type_node,
build_index_type (size_int (len)));
*line = build_int_cst (NULL_TREE, line_number);
if (col)
@ -1834,7 +1834,7 @@ build_call_raise (int msg, Node_Id gnat_node, char kind)
return
build_call_n_expr (fndecl, 2,
build1 (ADDR_EXPR,
build_pointer_type (unsigned_char_type_node),
build_pointer_type (char_type_node),
filename),
line);
}
@ -1858,7 +1858,7 @@ build_call_raise_column (int msg, Node_Id gnat_node, char kind)
return
build_call_n_expr (fndecl, 3,
build1 (ADDR_EXPR,
build_pointer_type (unsigned_char_type_node),
build_pointer_type (char_type_node),
filename),
line, col);
}
@ -1883,7 +1883,7 @@ build_call_raise_range (int msg, Node_Id gnat_node, char kind,
return
build_call_n_expr (fndecl, 6,
build1 (ADDR_EXPR,
build_pointer_type (unsigned_char_type_node),
build_pointer_type (char_type_node),
filename),
line, col,
convert (integer_type_node, index),