This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Fix 'char' compatibility with C
- From: Eric Botcazou <ebotcazou at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Wed, 20 Jan 2016 09:59:27 +0100
- Subject: [Ada] Fix 'char' compatibility with C
- Authentication-results: sourceware.org; auth=none
As promised earlier, this fixes the signedness compatibility issue between
Character/Interfaces.C.char in Ada and 'char' in the C family of languages.
Tested on x86_64-suse-linux, applied on the mainline.
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): Replaceunsigned_char_type_node
with char_type_node.
(build_call_raise): Likewise.
(build_call_raise_column): Likewise.
(build_call_raise_range): Likewise.
--
Eric Botcazou
Index: exp_ch2.adb
===================================================================
--- exp_ch2.adb (revision 232465)
+++ exp_ch2.adb (working copy)
@@ -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
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 232503)
+++ gcc-interface/decl.c (working copy)
@@ -1560,16 +1560,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
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_entit
&& 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_entit
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_entit
{
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_entit
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_entit
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));
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h (revision 232503)
+++ gcc-interface/gigi.h (working copy)
@@ -604,6 +604,9 @@ extern void build_dummy_unc_pointer_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;
+}
Index: gcc-interface/lang.opt
===================================================================
--- gcc-interface/lang.opt (revision 232465)
+++ gcc-interface/lang.opt (working copy)
@@ -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.
Index: gcc-interface/misc.c
===================================================================
--- gcc-interface/misc.c (revision 232503)
+++ gcc-interface/misc.c (working copy)
@@ -169,7 +169,8 @@ gnat_handle_option (size_t scode, const
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. */
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 232503)
+++ gcc-interface/trans.c (working copy)
@@ -231,7 +231,6 @@ static void elaborate_all_entities (Node
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 excep
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 excep
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, tre
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, tre
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, t
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, t
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, t
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_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_array_object = maybe_implicit_deref (gnu_array_object);
+ gnu_array_object = maybe_unconstrained_array (gnu_array_object);
+
+ 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_
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.
Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c (revision 232503)
+++ gcc-interface/utils.c (working copy)
@@ -1595,6 +1595,48 @@ record_builtin_type (const char *name, t
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, i
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))
Index: gcc-interface/utils2.c
===================================================================
--- gcc-interface/utils2.c (revision 232503)
+++ gcc-interface/utils2.c (working copy)
@@ -1804,7 +1804,7 @@ expand_sloc (Node_Id gnat_node, tree *fi
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_
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_I
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
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),