diff options
author | Eric Botcazou <ebotcazou@adacore.com> | 2016-01-20 09:01:34 +0000 |
---|---|---|
committer | Eric Botcazou <ebotcazou@gcc.gnu.org> | 2016-01-20 09:01:34 +0000 |
commit | 825da0d20f71cd82fa58e16e92099879e9a8b8f2 (patch) | |
tree | 31f580aa64b5ca42d70c133e1b634e5d8fb6daeb /gcc | |
parent | dd6f2cf98c132d493c9ba7c5602d2ade2efa97f4 (diff) | |
download | gcc-825da0d20f71cd82fa58e16e92099879e9a8b8f2.zip gcc-825da0d20f71cd82fa58e16e92099879e9a8b8f2.tar.gz gcc-825da0d20f71cd82fa58e16e92099879e9a8b8f2.tar.bz2 |
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
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/ChangeLog | 43 | ||||
-rw-r--r-- | gcc/ada/exp_ch2.adb | 13 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/decl.c | 38 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/gigi.h | 30 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/lang.opt | 4 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/misc.c | 6 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/trans.c | 243 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/utils.c | 45 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/utils2.c | 8 |
9 files changed, 238 insertions, 192 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 64e4c71..23780de 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index b926e10..88dc824 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -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 diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 556f079..74bc95b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -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)); diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index cd3d5b6..848cabf 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -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; +} diff --git a/gcc/ada/gcc-interface/lang.opt b/gcc/ada/gcc-interface/lang.opt index 302806c..ccae6fa 100644 --- a/gcc/ada/gcc-interface/lang.opt +++ b/gcc/ada/gcc-interface/lang.opt @@ -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. diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 33839f3..992ac0a 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -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. */ diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index eacab82..0f626d4 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -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_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_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. diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 95886f7..0ce571a 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -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)) diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index efeb147..ba4a5dca 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -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), |