diff options
Diffstat (limited to 'gcc/ada/gcc-interface')
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 22 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 8 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/decl.cc | 96 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/gigi.h | 5 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/misc.cc | 25 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.cc | 312 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils.cc | 11 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils2.cc | 45 |
8 files changed, 270 insertions, 254 deletions
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 9507f2f..364dea6 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -71,10 +71,11 @@ else ADAFLAGS=$(COMMON_ADAFLAGS) endif +ADA_CFLAGS = ALL_ADAFLAGS = \ - $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) $(WARN_ADAFLAGS) + $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) \ + $(WARN_ADAFLAGS) $(PICFLAG) FORCE_DEBUG_ADAFLAGS = -g -ADA_CFLAGS = COMMON_ADA_INCLUDES = -I- -I. -Iada/generated -Iada -I$(srcdir)/ada STAGE1_LIBS= @@ -536,6 +537,8 @@ GNAT_ADA_OBJS+= \ ada/libgnat/s-secsta.o \ ada/libgnat/s-soflin.o \ ada/libgnat/s-soliin.o \ + ada/libgnat/s-spark.o \ + ada/libgnat/s-spcuop.o \ ada/libgnat/s-stache.o \ ada/libgnat/s-stalib.o \ ada/libgnat/s-stoele.o \ @@ -1109,7 +1112,7 @@ ada/b_gnat1.adb : $(GNAT1_ADA_OBJS) ada/b_gnat1.o : ada/b_gnat1.adb # Do not use ADAFLAGS to get rid of -gnatg which generates a lot # of style messages. - $(CC) -c $(CFLAGS) $(ADA_CFLAGS) -gnatp -gnatws $(ADA_INCLUDES) \ + $(CC) -c $(CFLAGS) $(ADA_CFLAGS) $(PICFLAG) -gnatp -gnatws $(ADA_INCLUDES) \ $< $(ADA_OUTPUT_OPTION) ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o @@ -1118,7 +1121,7 @@ ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o $(MV) b_gnatb.adb b_gnatb.ads ada/ ada/b_gnatb.o : ada/b_gnatb.adb - $(CC) -c $(CFLAGS) $(ADA_CFLAGS) -gnatp -gnatws $(ADA_INCLUDES) \ + $(CC) -c $(CFLAGS) $(ADA_CFLAGS) $(PICFLAG) -gnatp -gnatws $(ADA_INCLUDES) \ $< $(ADA_OUTPUT_OPTION) include $(srcdir)/ada/Make-generated.in @@ -1172,17 +1175,6 @@ ada/gnatvsn.o : ada/gnatvsn.adb ada/generated/gnatvsn.ads $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) -# Dependencies for windows specific tool (mdll) - -ada/mdll.o : ada/mdll.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - -ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - -ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - # All generated files. Perhaps we should build all of these in the same # subdirectory, and get rid of ada/bldtools. # Warning: the files starting with ada/gnat.ads are not really generated, diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index da6a56f..dc0e54f 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -91,6 +91,7 @@ LS = ls RANLIB = @RANLIB@ RANLIB_FLAGS = @ranlib_flags@ AWK = @AWK@ +PICFLAG = @PICFLAG@ COMPILER = $(CC) COMPILER_FLAGS = $(CFLAGS) @@ -239,7 +240,11 @@ ALL_CPPFLAGS = $(CPPFLAGS) ALL_COMPILERFLAGS = $(ALL_CFLAGS) # This is where we get libiberty.a from. +ifeq ($(PICFLAG),) LIBIBERTY = ../../libiberty/libiberty.a +else +LIBIBERTY = ../../libiberty/pic/libiberty.a +endif # We need to link against libbacktrace because diagnostic.c in # libcommon.a uses it. @@ -256,9 +261,6 @@ TOOLS_LIBS = ../version.o ../link.o ../targext.o ../../ggc-none.o \ $(LIBGNAT) $(LIBINTL) $(LIBICONV) ../$(LIBBACKTRACE) ../$(LIBIBERTY) \ $(SYSLIBS) $(TGT_LIB) -# Add -no-pie to TOOLS_LIBS since some of them are compiled with -fno-PIE. -TOOLS_LIBS += @NO_PIE_FLAG@ - # Specify the directories to be searched for header files. # Both . and srcdir are used, in that order, # so that tm.h and config.h will be found in the compilation diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index d24adf3..494b24e 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -785,7 +785,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE && No (gnat_renamed_obj)) || TYPE_IS_DUMMY_P (gnu_type) - || TREE_CODE (gnu_type) == VOID_TYPE) + || VOID_TYPE_P (gnu_type)) { gcc_assert (type_annotate_only); if (this_global) @@ -840,7 +840,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (TREE_CODE (gnu_expr) == COMPONENT_REF && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) - && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL + && VAR_P (TREE_OPERAND (gnu_expr, 0)) && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0)) || DECL_READONLY_ONCE_ELAB (TREE_OPERAND (gnu_expr, 0)))) @@ -1076,9 +1076,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) || EXPRESSION_CLASS_P (inner) /* We need to detect the case where a temporary is created to hold the return value, since we cannot safely rename it at - top level as it lives only in the elaboration routine. */ - || (TREE_CODE (inner) == VAR_DECL - && DECL_RETURN_VALUE_P (inner)) + top level because it lives only in the elaboration routine. + But, at a lower level, an object initialized by a function + call may be (implicitly) renamed as this temporary by the + front-end and, in this case, we cannot make a copy. */ + || (VAR_P (inner) + && DECL_RETURN_VALUE_P (inner) + && global_bindings_p ()) /* We also need to detect the case where the front-end creates a dangling 'reference to a function call at top level and substitutes it in the renaming, for example: @@ -1092,12 +1096,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) q__b : boolean renames q__R1s.all.e (1); We cannot safely rename the rewritten expression since the - underlying object lives only in the elaboration routine. */ - || (TREE_CODE (inner) == INDIRECT_REF + underlying object lives only in the elaboration routine but, + as above, this cannot be done at a lower level. */ + || (INDIRECT_REF_P (inner) && (inner = remove_conversions (TREE_OPERAND (inner, 0), true)) - && TREE_CODE (inner) == VAR_DECL - && DECL_RETURN_VALUE_P (inner))) + && VAR_P (inner) + && DECL_RETURN_VALUE_P (inner) + && global_bindings_p ())) ; /* Otherwise, this is an lvalue being renamed, so it needs to be @@ -1156,7 +1162,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr); - create_var_decl (gnu_entity_name, gnu_ext_name, + create_var_decl (gnu_entity_name, NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, const_flag, Is_Public (gnat_entity), imported_p, static_flag, volatile_flag, @@ -1212,7 +1218,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type)) && !gnu_expr && !Is_Imported (gnat_entity)) - gnu_expr = integer_zero_node; + gnu_expr = null_pointer_node; /* If we are defining the object and it has an Address clause, we must either get the address expression from the saved GCC tree for the @@ -1527,7 +1533,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If this name is external or a name was specified, use it, but don't use the Interface_Name with an address clause (see cd30005). */ - if ((Is_Public (gnat_entity) && !Is_Imported (gnat_entity)) + if ((Is_Public (gnat_entity) && !imported_p) || (Present (Interface_Name (gnat_entity)) && No (Address_Clause (gnat_entity)))) gnu_ext_name = create_concat_name (gnat_entity, NULL); @@ -1611,7 +1617,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) and optimization isn't enabled, then force it in memory so that a register won't be allocated to it with possible subparts left uninitialized and reaching the register allocator. */ - else if (TREE_CODE (gnu_decl) == VAR_DECL + else if (VAR_P (gnu_decl) && !DECL_EXTERNAL (gnu_decl) && !TREE_STATIC (gnu_decl) && DECL_MODE (gnu_decl) != BLKmode @@ -2241,9 +2247,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) index += (convention_fortran_p ? - 1 : 1), gnat_index = Next_Index (gnat_index)) { + const Entity_Id gnat_index_type = Etype (gnat_index); const bool is_flb - = Is_Fixed_Lower_Bound_Index_Subtype (Etype (gnat_index)); - tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); + = Is_Fixed_Lower_Bound_Index_Subtype (gnat_index_type); + tree gnu_index_type = get_unpadded_type (gnat_index_type); tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type); tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type); tree gnu_index_base_type = get_base_type (gnu_index_type); @@ -2479,6 +2486,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) const int ndim = Number_Dimensions (gnat_entity); tree gnu_base_type = gnu_type; tree *gnu_index_types = XALLOCAVEC (tree, ndim); + bool *gnu_null_ranges = XALLOCAVEC (bool, ndim); tree gnu_max_size = size_one_node; bool need_index_type_struct = false; int index; @@ -2494,7 +2502,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnat_index = Next_Index (gnat_index), gnat_base_index = Next_Index (gnat_base_index)) { - tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); + const Entity_Id gnat_index_type = Etype (gnat_index); + tree gnu_index_type = get_unpadded_type (gnat_index_type); tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type); tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type); tree gnu_index_base_type = get_base_type (gnu_index_type); @@ -2671,6 +2680,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = create_index_type (gnu_min, gnu_high, gnu_index_type, gnat_entity); + /* Record whether the range is known to be null at compile time + to disambiguate it from too large ranges. */ + const Entity_Id gnat_ui_type = Underlying_Type (gnat_index_type); + gnu_null_ranges[index] + = Is_Null_Range (Type_Low_Bound (gnat_ui_type), + Type_High_Bound (gnat_ui_type)); + /* We need special types for debugging information to point to the index types if they have variable bounds, are not integer types, are biased or are wider than sizetype. These are GNAT @@ -2737,7 +2753,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (array_type_has_nonaliased_component (gnu_type, gnat_entity)) set_nonaliased_component_on_array_type (gnu_type); - /* Kludge to remove the TREE_OVERFLOW flag for the sake of LTO + /* Clear the TREE_OVERFLOW flag, if any, for null arrays. */ + if (gnu_null_ranges[index]) + { + TYPE_SIZE (gnu_type) = bitsize_zero_node; + TYPE_SIZE_UNIT (gnu_type) = size_zero_node; + } + + /* Kludge to clear the TREE_OVERFLOW flag for the sake of LTO on maximally-sized array types designed by access types. */ if (integer_zerop (TYPE_SIZE (gnu_type)) && TREE_OVERFLOW (TYPE_SIZE (gnu_type)) @@ -3954,10 +3977,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = gnu_ext_name_for_subprog (gnat_entity, gnu_entity_name); const enum inline_status_t inline_status = inline_status_for_subprog (gnat_entity); - bool public_flag = Is_Public (gnat_entity) || imported_p; /* Subprograms marked both Intrinsic and Always_Inline need not have a body of their own. */ - bool extern_flag + const bool extern_flag = ((Is_Public (gnat_entity) && !definition) || imported_p || (Is_Intrinsic_Subprogram (gnat_entity) @@ -4112,10 +4134,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) else gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name, - gnu_type, gnu_param_list, - inline_status, public_flag, - extern_flag, artificial_p, - debug_info_p, + gnu_type, gnu_param_list, inline_status, + Is_Public (gnat_entity) || imported_p, + extern_flag, artificial_p, debug_info_p, definition && imported_p, attr_list, gnat_entity); } @@ -4364,7 +4385,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If the alignment has not already been processed and this is not an unconstrained array type, see if an alignment is specified. If not, we pick a default alignment for atomic objects. */ - if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + if (align > 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) ; else if (Known_Alignment (gnat_entity)) { @@ -4653,6 +4674,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If this is not an unconstrained array type, set some flags. */ if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE) { + bool align_clause; + /* Record the property that objects of tagged types are guaranteed to be properly aligned. This is necessary because conversions to the class-wide type are translated into conversions to the root type, @@ -4665,8 +4688,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (is_by_ref && !VOID_TYPE_P (gnu_type)) TYPE_BY_REFERENCE_P (gnu_type) = 1; - /* Record whether an alignment clause was specified. */ - if (Present (Alignment_Clause (gnat_entity))) + /* Record whether an alignment clause was specified. At this point + scalar types with a non-confirming clause have been wrapped into + a record type, so only scalar types with a confirming clause are + left untouched; we do not set the flag on them except if they are + types whose default alignment is specifically capped in order not + to lose the specified alignment. */ + if ((AGGREGATE_TYPE_P (gnu_type) + && Present (Alignment_Clause (gnat_entity))) + || (double_float_alignment > 0 + && is_double_float_or_array (gnat_entity, &align_clause) + && align_clause) + || (double_scalar_alignment > 0 + && is_double_scalar_or_array (gnat_entity, &align_clause) + && align_clause)) TYPE_USER_ALIGN (gnu_type) = 1; /* Record whether a pragma Universal_Aliasing was specified. */ @@ -6659,6 +6694,10 @@ range_cannot_be_superflat (Node_Id gnat_range) Node_Id gnat_scalar_range; tree gnu_lb, gnu_hb, gnu_lb_minus_one; + /* This is the easy case. */ + if (Cannot_Be_Superflat (gnat_range)) + return true; + /* If the low bound is not constant, take the worst case by finding an upper bound for its type, repeatedly if need be. */ while (Nkind (gnat_lb) != N_Integer_Literal @@ -6703,8 +6742,7 @@ range_cannot_be_superflat (Node_Id gnat_range) static bool constructor_address_p (tree gnu_expr) { - while (TREE_CODE (gnu_expr) == NOP_EXPR - || TREE_CODE (gnu_expr) == CONVERT_EXPR + while (CONVERT_EXPR_P (gnu_expr) || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR) gnu_expr = TREE_OPERAND (gnu_expr, 0); @@ -7047,7 +7085,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s, expr_variable_p = !(inner - && TREE_CODE (inner) == VAR_DECL + && VAR_P (inner) && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner))); } diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index fee0450..ec85ce4 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -245,11 +245,12 @@ extern void gigi (Node_Id gnat_root, struct List_Header *list_headers_ptr, Nat number_file, struct File_Info_Type *file_info_ptr, + Entity_Id standard_address, Entity_Id standard_boolean, - Entity_Id standard_integer, Entity_Id standard_character, - Entity_Id standard_long_long_float, Entity_Id standard_exception_type, + Entity_Id standard_integer, + Entity_Id standard_long_long_float, Int gigi_operating_mode); #ifdef __cplusplus diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc index b18ca8c..30319ae 100644 --- a/gcc/ada/gcc-interface/misc.cc +++ b/gcc/ada/gcc-interface/misc.cc @@ -267,9 +267,6 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) /* No return type warnings for Ada. */ warn_return_type = 0; - /* No string overflow warnings for Ada. */ - warn_stringop_overflow = 0; - /* No caret by default for Ada. */ if (!OPTION_SET_P (flag_diagnostics_show_caret)) global_dc->show_caret = false; @@ -333,13 +330,23 @@ internal_error_function (diagnostic_context *context, const char *msgid, sp.Bounds = &temp; sp.Array = buffer; - xloc = expand_location (input_location); - if (context->show_column && xloc.column != 0) - loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column); + if (input_location == UNKNOWN_LOCATION) + { + loc = NULL; + temp_loc.Low_Bound = 1; + temp_loc.High_Bound = 0; + } else - loc = xasprintf ("%s:%d", xloc.file, xloc.line); - temp_loc.Low_Bound = 1; - temp_loc.High_Bound = strlen (loc); + { + xloc = expand_location (input_location); + if (context->show_column && xloc.column != 0) + loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column); + else + loc = xasprintf ("%s:%d", xloc.file, xloc.line); + temp_loc.Low_Bound = 1; + temp_loc.High_Bound = strlen (loc); + } + sp_loc.Bounds = &temp_loc; sp_loc.Array = loc; diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 5fc1a26..ddc7b6d 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -290,11 +290,12 @@ gigi (Node_Id gnat_root, struct List_Header *list_headers_ptr, Nat number_file, struct File_Info_Type *file_info_ptr, + Entity_Id standard_address, Entity_Id standard_boolean, - Entity_Id standard_integer, Entity_Id standard_character, - Entity_Id standard_long_long_float, Entity_Id standard_exception_type, + Entity_Id standard_integer, + Entity_Id standard_long_long_float, Int gigi_operating_mode) { Node_Id gnat_iter; @@ -375,14 +376,19 @@ gigi (Node_Id gnat_root, double_float_alignment = get_target_double_float_alignment (); double_scalar_alignment = get_target_double_scalar_alignment (); - /* Record the builtin types. Define `integer' and `character' first so that - dbx will output them first. */ + /* Record the builtin types. */ + record_builtin_type ("address", pointer_sized_int_node, false); record_builtin_type ("integer", integer_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); - /* Save the type we made for integer as the type for Standard.Integer. */ + /* Save the type we made for address as the type for Standard.Address. */ + save_gnu_tree (Base_Type (standard_address), + TYPE_NAME (pointer_sized_int_node), + false); + + /* Likewise for integer as the type for Standard.Integer. */ save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node), false); @@ -1241,7 +1247,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) /* Do the final dereference. */ gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - if ((TREE_CODE (gnu_result) == INDIRECT_REF + if ((INDIRECT_REF_P (gnu_result) || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) && No (Address_Clause (gnat_entity))) TREE_THIS_NOTRAP (gnu_result) = 1; @@ -1708,12 +1714,17 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) case Attr_Address: case Attr_Unrestricted_Access: /* Conversions don't change the address of references but can cause - build_unary_op to miss the references below, so strip them off. + build_unary_op to miss the references below so strip them off. + + Also remove the conversions applied to declarations as the intent is + to take the decls' address, not that of the copies that the + conversions may create. + On the contrary, if the address-of operation causes a temporary to be created, then it must be created with the proper type. */ gnu_expr = remove_conversions (gnu_prefix, !Must_Be_Byte_Aligned (gnat_node)); - if (REFERENCE_CLASS_P (gnu_expr)) + if (REFERENCE_CLASS_P (gnu_expr) || DECL_P (gnu_expr)) gnu_prefix = gnu_expr; /* If we are taking 'Address of an unconstrained object, this is the @@ -1939,24 +1950,20 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) /* If this is a dereference and we have a special dynamic constrained subtype on the prefix, use it to compute the size; otherwise, use the designated subtype. */ - if (Nkind (gnat_prefix) == N_Explicit_Dereference) + if (Nkind (gnat_prefix) == N_Explicit_Dereference + && Present (Actual_Designated_Subtype (gnat_prefix))) { - Node_Id gnat_actual_subtype - = Actual_Designated_Subtype (gnat_prefix); + tree gnu_actual_obj_type + = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_prefix)); tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix))); - if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type) - && Present (gnat_actual_subtype)) - { - tree gnu_actual_obj_type - = gnat_to_gnu_type (gnat_actual_subtype); - gnu_type - = build_unc_object_type_from_ptr (gnu_ptr_type, - gnu_actual_obj_type, - get_identifier ("SIZE"), - false); - } + if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) + gnu_type + = build_unc_object_type_from_ptr (gnu_ptr_type, + gnu_actual_obj_type, + get_identifier ("SIZE"), + false); } gnu_result = TYPE_SIZE (gnu_type); @@ -1971,7 +1978,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) if (TREE_CODE (gnu_prefix) != TYPE_DECL) { gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo); } else if (CONTAINS_PLACEHOLDER_P (gnu_result)) @@ -2204,7 +2212,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) handling. Note that these attributes could not have been used on an unconstrained array type. */ gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo); /* Cache the expression we have just computed. Since we want to do it @@ -2366,7 +2375,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are handling. */ gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo); break; } @@ -3391,7 +3401,7 @@ struct nrv_data static inline bool is_nrv_p (bitmap nrv, tree t) { - return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t)); + return VAR_P (t) && bitmap_bit_p (nrv, DECL_UID (t)); } /* Helper function for walk_tree, used by finalize_nrv below. */ @@ -4136,7 +4146,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_param = Next_Formal_With_Extras (gnat_param)) { tree gnu_param = get_gnu_tree (gnat_param); - bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL); + bool is_var_decl = VAR_P (gnu_param); annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE, DECL_BY_REF_P (gnu_param)); @@ -4254,8 +4264,16 @@ static inline bool node_is_component (Node_Id gnat_node) { const Node_Kind k = Nkind (gnat_node); - return - (k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice); + return k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice; +} + +/* Return true if GNAT_NODE is a type conversion. */ + +static inline bool +node_is_type_conversion (Node_Id gnat_node) +{ + const Node_Kind k = Nkind (gnat_node); + return k == N_Type_Conversion || k == N_Unchecked_Type_Conversion; } /* Compute whether GNAT_NODE requires atomic access and set TYPE to the type @@ -4306,8 +4324,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync) } /* Now strip any type conversion from GNAT_NODE. */ - if (Nkind (gnat_node) == N_Type_Conversion - || Nkind (gnat_node) == N_Unchecked_Type_Conversion) + if (node_is_type_conversion (gnat_node)) gnat_node = Expression (gnat_node); /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as @@ -4392,21 +4409,44 @@ static void get_storage_model_access (Node_Id gnat_node, Entity_Id *gnat_smo) { const Node_Id gnat_parent = Parent (gnat_node); + *gnat_smo = Empty; - /* If we are the prefix of the parent, then the access is above us. */ - if (node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node) + switch (Nkind (gnat_parent)) { - *gnat_smo = Empty; + case N_Attribute_Reference: + /* If the parent is an attribute reference that requires an lvalue and + gnat_node is the Prefix (i.e. not a parameter), we do not need to + actually access any storage. */ + if (lvalue_required_for_attribute_p (gnat_parent) + && Prefix (gnat_parent) == gnat_node) + return; + break; + + case N_Object_Renaming_Declaration: + /* Nothing to do for the identifier in an object renaming declaration, + the renaming itself does not need storage model access. */ return; + + default: + break; } - /* Now strip any type conversion from GNAT_NODE. */ - if (Nkind (gnat_node) == N_Type_Conversion - || Nkind (gnat_node) == N_Unchecked_Type_Conversion) - gnat_node = Expression (gnat_node); + /* If we are the prefix of the parent, then the access is above us. */ + if ((node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node) + || (node_is_type_conversion (gnat_parent) + && node_is_component (Parent (gnat_parent)) + && Prefix (Parent (gnat_parent)) == gnat_parent)) + return; + /* Find the innermost prefix in GNAT_NODE, stripping any type conversion. */ + if (node_is_type_conversion (gnat_node)) + gnat_node = Expression (gnat_node); while (node_is_component (gnat_node)) - gnat_node = Prefix (gnat_node); + { + gnat_node = Prefix (gnat_node); + if (node_is_type_conversion (gnat_node)) + gnat_node = Expression (gnat_node); + } *gnat_smo = get_storage_model (gnat_node); } @@ -4536,14 +4576,13 @@ elaborate_profile (Entity_Id first_formal, Entity_Id result_type) N_Assignment_Statement and the result is to be placed into that object. ATOMIC_ACCESS is the type of atomic access to be used for the assignment to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment - to GNU_TARGET requires atomic synchronization. GNAT_STORAGE_MODEL is the - storage model object to be used for the assignment to GNU_TARGET or Empty - if there is none. */ + to GNU_TARGET requires atomic synchronization. GNAT_SMO is the storage + model object to be used for the assignment to GNU_TARGET or Empty if there + is none. */ static tree Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, - atomic_acces_t atomic_access, bool atomic_sync, - Entity_Id gnat_storage_model) + atomic_acces_t atomic_access, bool atomic_sync, Entity_Id gnat_smo) { const bool function_call = (Nkind (gnat_node) == N_Function_Call); const bool returning_value = (function_call && !gnu_target); @@ -4556,7 +4595,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ tree gnu_subprog_type = TREE_TYPE (gnu_subprog); /* The return type of the FUNCTION_TYPE. */ - tree gnu_result_type;; + tree gnu_result_type; const bool frontend_builtin = (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_BUILT_IN_CLASS (gnu_subprog) == BUILT_IN_FRONTEND); @@ -4575,7 +4614,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, Node_Id gnat_actual; atomic_acces_t aa_type; bool aa_sync; - Entity_Id gnat_smo; /* The only way we can make a call via an access type is if GNAT_NAME is an explicit dereference. In that case, get the list of formal args from the @@ -4639,7 +4677,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, } /* We must elaborate the entire profile now because, if it references types - that were initially incomplete,, their elaboration changes the contents + that were initially incomplete, their elaboration changes the contents of GNU_SUBPROG_TYPE and, in particular, may change the result type. */ elaborate_profile (gnat_formal, gnat_result_type); @@ -4727,8 +4765,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, != TYPE_SIZE (TREE_TYPE (gnu_target)) && type_is_padding_self_referential (gnu_result_type)) || (gnu_target - && Present (gnat_storage_model) - && Present (Storage_Model_Copy_To (gnat_storage_model))))) + && Present (gnat_smo) + && Present (Storage_Model_Copy_To (gnat_smo))))) { gnu_retval = create_temporary ("R", gnu_result_type); DECL_RETURN_VALUE_P (gnu_retval) = 1; @@ -4799,19 +4837,12 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name); } - get_storage_model_access (gnat_actual, &gnat_smo); - - /* If we are passing a non-addressable actual parameter by reference, - pass the address of a copy. Likewise if it needs to be accessed with - a storage model. In the In Out or Out case, set up to copy back out - after the call. */ + /* If we are passing a non-addressable parameter by reference, pass the + address of a copy. In the In Out or Out case, set up to copy back + out after the call. */ if (is_by_ref_formal_parm && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name))) - && (!addressable_p (gnu_name, gnu_name_type) - || (Present (gnat_smo) - && (Present (Storage_Model_Copy_From (gnat_smo)) - || (!in_param - && Present (Storage_Model_Copy_To (gnat_smo))))))) + && !addressable_p (gnu_name, gnu_name_type)) { tree gnu_orig = gnu_name, gnu_temp, gnu_stmt; @@ -4882,40 +4913,21 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, } /* Create an explicit temporary holding the copy. */ - tree gnu_temp_type; - if (Nkind (gnat_actual) == N_Explicit_Dereference - && Present (Actual_Designated_Subtype (gnat_actual))) - gnu_temp_type - = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_actual)); - else - gnu_temp_type = TREE_TYPE (gnu_name); /* Do not initialize it for the _Init parameter of an initialization procedure since no data is meant to be passed in. */ if (Ekind (gnat_formal) == E_Out_Parameter && Is_Entity_Name (gnat_subprog) && Is_Init_Proc (Entity (gnat_subprog))) - gnu_name = gnu_temp = create_temporary ("A", gnu_temp_type); + gnu_name = gnu_temp = create_temporary ("A", TREE_TYPE (gnu_name)); /* Initialize it on the fly like for an implicit temporary in the other cases, as we don't necessarily have a statement list. */ else { - if (Present (gnat_smo) - && Present (Storage_Model_Copy_From (gnat_smo))) - { - gnu_temp = create_temporary ("A", gnu_temp_type); - gnu_stmt - = build_storage_model_load (gnat_smo, gnu_temp, - gnu_name, - TYPE_SIZE_UNIT (gnu_temp_type)); - set_expr_location_from_node (gnu_stmt, gnat_actual); - } - else - gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt, - gnat_actual); - - gnu_name = build_compound_expr (gnu_temp_type, gnu_stmt, + gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt, + gnat_actual); + gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt, gnu_temp); } @@ -4931,16 +4943,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1))) gnu_orig = TREE_OPERAND (gnu_orig, 2); - if (Present (gnat_smo) - && Present (Storage_Model_Copy_To (gnat_smo))) - gnu_stmt - = build_storage_model_store (gnat_smo, gnu_orig, - gnu_temp, - TYPE_SIZE_UNIT (gnu_temp_type)); - else - gnu_stmt - = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, - gnu_temp); + gnu_stmt + = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp); set_expr_location_from_node (gnu_stmt, gnat_node); append_to_statement_list (gnu_stmt, &gnu_after_list); @@ -4951,19 +4955,12 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, tree gnu_actual = gnu_name; /* If atomic access is required for an In or In Out actual parameter, - build the atomic load. Or else, if storage model access is required, - build the special load. */ + build the atomic load. */ if (is_true_formal_parm && !is_by_ref_formal_parm - && Ekind (gnat_formal) != E_Out_Parameter) - { - if (simple_atomic_access_required_p (gnat_actual, &aa_sync)) - gnu_actual = build_atomic_load (gnu_actual, aa_sync); - - else if (Present (gnat_smo) - && Present (Storage_Model_Copy_From (gnat_smo))) - gnu_actual = build_storage_model_load (gnat_smo, gnu_actual); - } + && Ekind (gnat_formal) != E_Out_Parameter + && simple_atomic_access_required_p (gnat_actual, &aa_sync)) + gnu_actual = build_atomic_load (gnu_actual, aa_sync); /* If this was a procedure call, we may not have removed any padding. So do it here for the part we will use as an input, if any. */ @@ -5327,7 +5324,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, } get_atomic_access (gnat_actual, &aa_type, &aa_sync); - get_storage_model_access (gnat_actual, &gnat_smo); /* If an outer atomic access is required for an actual parameter, build the load-modify-store sequence. */ @@ -5341,13 +5337,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, gnu_result = build_atomic_store (gnu_actual, gnu_result, aa_sync); - /* Or else, if a storage model access is required, build the special - store. */ - else if (Present (gnat_smo) - && Present (Storage_Model_Copy_To (gnat_smo))) - gnu_result - = build_storage_model_store (gnat_smo, gnu_actual, gnu_result); - /* Otherwise build a regular assignment. */ else gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, @@ -5422,11 +5411,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, = build_load_modify_store (gnu_target, gnu_call, gnat_node); else if (atomic_access == SIMPLE_ATOMIC) gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync); - else if (Present (gnat_storage_model) - && Present (Storage_Model_Copy_To (gnat_storage_model))) + else if (Present (gnat_smo) + && Present (Storage_Model_Copy_To (gnat_smo))) gnu_call - = build_storage_model_store (gnat_storage_model, gnu_target, - gnu_call); + = build_storage_model_store (gnat_smo, gnu_target, gnu_call); else gnu_call = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call); @@ -6139,16 +6127,9 @@ lhs_or_actual_p (Node_Id gnat_node) static bool present_in_lhs_or_actual_p (Node_Id gnat_node) { - if (lhs_or_actual_p (gnat_node)) - return true; - - const Node_Kind kind = Nkind (Parent (gnat_node)); - - if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion) - && lhs_or_actual_p (Parent (gnat_node))) - return true; - - return false; + return lhs_or_actual_p (gnat_node) + || (node_is_type_conversion (Parent (gnat_node)) + && lhs_or_actual_p (Parent (gnat_node))); } /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far @@ -6728,7 +6709,8 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) instantiate_load_in_array_ref (gnu_result, gnat_smo); } @@ -6773,7 +6755,8 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type, gnu_array_object, gnu_expr); - if (Present (gnat_smo)) + if (Present (gnat_smo) + && Present (Storage_Model_Copy_From (gnat_smo))) instantiate_load_in_array_ref (gnu_result, gnat_smo); /* If storage model access is required on the RHS, build the load. */ @@ -6908,7 +6891,7 @@ gnat_to_gnu (Node_Id gnat_node) && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type)) gnu_aggr_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type))); - else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE) + else if (VECTOR_TYPE_P (gnu_result_type)) gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type); else gnu_aggr_type = gnu_result_type; @@ -7127,9 +7110,9 @@ gnat_to_gnu (Node_Id gnat_node) gnu_rhs = convert (gnu_count_type, gnu_rhs); gnu_max_shift = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type)); - /* If the result type is larger than a word, then declare the dependence - on the libgcc routine. */ - if (TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + /* If the result type is larger than a word, then declare the + dependence on the libgcc routine. */ + if (TYPE_PRECISION (gnu_type) > BITS_PER_WORD) Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); } @@ -7146,7 +7129,7 @@ gnat_to_gnu (Node_Id gnat_node) /* If this is a modulo/remainder and the result type is larger than a word, then declare the dependence on the libgcc routine. */ else if ((kind == N_Op_Mod ||kind == N_Op_Rem) - && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + && TYPE_PRECISION (gnu_type) > BITS_PER_WORD) Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); /* Pending generic support for efficient vector logical operations in @@ -7406,13 +7389,13 @@ gnat_to_gnu (Node_Id gnat_node) /* Otherwise we need to build the assignment statement manually. */ else { + const Node_Id gnat_name = Name (gnat_node); const Node_Id gnat_expr = Expression (gnat_node); const Node_Id gnat_inner = Nkind (gnat_expr) == N_Qualified_Expression ? Expression (gnat_expr) : gnat_expr; - const Entity_Id gnat_type - = Underlying_Type (Etype (Name (gnat_node))); + const Entity_Id gnat_type = Underlying_Type (Etype (gnat_name)); const bool use_memset_p = Is_Array_Type (gnat_type) && Nkind (gnat_inner) == N_Aggregate @@ -7437,8 +7420,8 @@ gnat_to_gnu (Node_Id gnat_node) gigi_checking_assert (!Do_Range_Check (gnat_expr)); - get_atomic_access (Name (gnat_node), &aa_type, &aa_sync); - get_storage_model_access (Name (gnat_node), &gnat_smo); + get_atomic_access (gnat_name, &aa_type, &aa_sync); + get_storage_model_access (gnat_name, &gnat_smo); /* If an outer atomic access is required on the LHS, build the load- modify-store sequence. */ @@ -7455,39 +7438,26 @@ gnat_to_gnu (Node_Id gnat_node) else if (Present (gnat_smo) && Present (Storage_Model_Copy_To (gnat_smo))) { + tree gnu_size; + /* We obviously cannot use memset in this case. */ gcc_assert (!use_memset_p); - tree t = remove_conversions (gnu_rhs, false); - - /* If a storage model load is present on the RHS then instantiate - the temporary associated with it now, lest it be of variable - size and thus could not be instantiated by gimplification. */ - if (TREE_CODE (t) == LOAD_EXPR) + /* If this is a dereference with a special dynamic constrained + subtype on the node, use it to compute the size. */ + if (Nkind (gnat_name) == N_Explicit_Dereference + && Present (Actual_Designated_Subtype (gnat_name))) { - t = TREE_OPERAND (t, 1); - gcc_assert (TREE_CODE (t) == CALL_EXPR); - - tree elem - = build_nonstandard_integer_type (BITS_PER_UNIT, 1); - tree size = fold_convert (sizetype, CALL_EXPR_ARG (t, 3)); - tree index = build_index_type (size); - tree temp - = create_temporary ("L", build_array_type (elem, index)); - tree arg = CALL_EXPR_ARG (t, 1); - CALL_EXPR_ARG (t, 1) - = build_unary_op (ADDR_EXPR, TREE_TYPE (arg), temp); - - start_stmt_group (); - add_stmt (t); - t = build_storage_model_store (gnat_smo, gnu_lhs, temp); - add_stmt (t); - gnu_result = end_stmt_group (); + tree gnu_actual_obj_type + = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_name)); + gnu_size = TYPE_SIZE_UNIT (gnu_actual_obj_type); } - else - gnu_result - = build_storage_model_store (gnat_smo, gnu_lhs, gnu_rhs); + gnu_size = NULL_TREE; + + gnu_result + = build_storage_model_store (gnat_smo, gnu_lhs, gnu_rhs, + gnu_size); } /* Or else, use memset when the conditions are met. This has already @@ -7740,7 +7710,7 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build2 (INIT_EXPR, void_type_node, gnu_ret_deref, gnu_ret_val); /* Avoid a useless copy with __builtin_return_slot. */ - if (TREE_CODE (gnu_ret_val) == INDIRECT_REF) + if (INDIRECT_REF_P (gnu_ret_val)) gnu_result = build3 (COND_EXPR, void_type_node, fold_build2 (NE_EXPR, boolean_type_node, @@ -8415,7 +8385,7 @@ gnat_to_gnu (Node_Id gnat_node) /* If we're supposed to return something of void_type, it means we have something we're elaborating for effect, so just return. */ - if (TREE_CODE (gnu_result_type) == VOID_TYPE) + if (VOID_TYPE_P (gnu_result_type)) return gnu_result; /* If the result is a constant that overflowed, raise Constraint_Error. */ @@ -8588,7 +8558,7 @@ gnat_to_gnu_external (Node_Id gnat_node) current_function_decl = NULL_TREE; /* Do not import locations from external units. */ - if (gnu_result && EXPR_P (gnu_result)) + if (CAN_HAVE_LOCATION_P (gnu_result)) SET_EXPR_LOCATION (gnu_result, UNKNOWN_LOCATION); return gnu_result; @@ -8722,7 +8692,7 @@ add_decl_expr (tree gnu_decl, Node_Id gnat_node) Note that walk_tree knows how to deal with TYPE_DECL, but neither VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */ MARK_VISITED (gnu_stmt); - if (TREE_CODE (gnu_decl) == VAR_DECL + if (VAR_P (gnu_decl) || TREE_CODE (gnu_decl) == CONST_DECL) { MARK_VISITED (DECL_SIZE (gnu_decl)); @@ -8739,7 +8709,7 @@ add_decl_expr (tree gnu_decl, Node_Id gnat_node) && !TYPE_FAT_POINTER_P (type)) MARK_VISITED (TYPE_ADA_SIZE (type)); - if (TREE_CODE (gnu_decl) == VAR_DECL && (gnu_init = DECL_INITIAL (gnu_decl))) + if (VAR_P (gnu_decl) && (gnu_init = DECL_INITIAL (gnu_decl))) { /* If this is a variable and an initializer is attached to it, it must be valid for the context. Similar to init_const in create_var_decl. */ @@ -9000,7 +8970,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, /* The expressions for the RM bounds must be gimplified to ensure that they are properly elaborated. See gimplify_decl_expr. */ - if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL) + if ((TREE_CODE (op) == TYPE_DECL || VAR_P (op)) && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)) && (INTEGRAL_TYPE_P (TREE_TYPE (op)) || SCALAR_FLOAT_TYPE_P (TREE_TYPE (op)))) @@ -9032,7 +9002,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE, convert (build_pointer_type (type), - integer_zero_node)); + null_pointer_node)); /* Otherwise, just make a VAR_DECL. */ else diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 392ec0b..8f1861b 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -1562,6 +1562,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, at the RTL level when the stand-alone object is accessed as a whole. */ if (align > 0 && RECORD_OR_UNION_TYPE_P (type) + && !TYPE_IS_FAT_POINTER_P (type) && TYPE_MODE (type) == BLKmode && !TYPE_BY_REFERENCE_P (type) && TREE_CODE (orig_size) == INTEGER_CST @@ -2802,7 +2803,7 @@ create_var_decl (tree name, tree asm_name, tree type, tree init, if (TREE_CODE (inner) == ADDR_EXPR && ((TREE_CODE (TREE_OPERAND (inner, 0)) == CALL_EXPR && !call_is_atomic_load (TREE_OPERAND (inner, 0))) - || (TREE_CODE (TREE_OPERAND (inner, 0)) == VAR_DECL + || (VAR_P (TREE_OPERAND (inner, 0)) && DECL_RETURN_VALUE_P (TREE_OPERAND (inner, 0))))) DECL_RETURN_VALUE_P (var_decl) = 1; } @@ -2853,7 +2854,7 @@ create_var_decl (tree name, tree asm_name, tree type, tree init, support global BSS sections, uninitialized global variables would go in DATA instead, thus increasing the size of the executable. */ if (!flag_no_common - && TREE_CODE (var_decl) == VAR_DECL + && VAR_P (var_decl) && TREE_PUBLIC (var_decl) && !have_global_bss_p ()) DECL_COMMON (var_decl) = 1; @@ -2871,13 +2872,13 @@ create_var_decl (tree name, tree asm_name, tree type, tree init, DECL_IGNORED_P (var_decl) = 1; /* ??? Some attributes cannot be applied to CONST_DECLs. */ - if (TREE_CODE (var_decl) == VAR_DECL) + if (VAR_P (var_decl)) process_attributes (&var_decl, &attr_list, true, gnat_node); /* Add this decl to the current binding level. */ gnat_pushdecl (var_decl, gnat_node); - if (TREE_CODE (var_decl) == VAR_DECL && asm_name) + if (VAR_P (var_decl) && asm_name) { /* Let the target mangle the name if this isn't a verbatim asm. */ if (*IDENTIFIER_POINTER (asm_name) != '*') @@ -5543,7 +5544,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) } } - /* Likewise if we are converting from a fixed-szie type to a type with self- + /* Likewise if we are converting from a fixed-size type to a type with self- referential size. We use the max size to do the padding in this case. */ else if (!INDIRECT_REF_P (expr) && TREE_CODE (expr) != STRING_CST diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc index 6c17675..95bbce2 100644 --- a/gcc/ada/gcc-interface/utils2.cc +++ b/gcc/ada/gcc-interface/utils2.cc @@ -68,7 +68,7 @@ get_base_type (tree type) while (TREE_TYPE (type) && (TREE_CODE (type) == INTEGER_TYPE - || TREE_CODE (type) == REAL_TYPE)) + || SCALAR_FLOAT_TYPE_P (type))) type = TREE_TYPE (type); return type; @@ -692,13 +692,14 @@ build_atomic_load (tree src, bool sync) = build_int_cst (integer_type_node, sync ? MEMMODEL_SEQ_CST : MEMMODEL_RELAXED); tree orig_src = src; - tree t, addr, val; + tree type, t, addr, val; unsigned int size; int fncode; /* Remove conversions to get the address of the underlying object. */ src = remove_conversions (src, false); - size = resolve_atomic_size (TREE_TYPE (src)); + type = TREE_TYPE (src); + size = resolve_atomic_size (type); if (size == 0) return orig_src; @@ -710,7 +711,7 @@ build_atomic_load (tree src, bool sync) /* First reinterpret the loaded bits in the original type of the load, then convert to the expected result type. */ - t = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (src), val); + t = fold_build1 (VIEW_CONVERT_EXPR, type, val); return convert (TREE_TYPE (orig_src), t); } @@ -728,13 +729,14 @@ build_atomic_store (tree dest, tree src, bool sync) = build_int_cst (integer_type_node, sync ? MEMMODEL_SEQ_CST : MEMMODEL_RELAXED); tree orig_dest = dest; - tree t, int_type, addr; + tree type, t, int_type, addr; unsigned int size; int fncode; /* Remove conversions to get the address of the underlying object. */ dest = remove_conversions (dest, false); - size = resolve_atomic_size (TREE_TYPE (dest)); + type = TREE_TYPE (dest); + size = resolve_atomic_size (type); if (size == 0) return build_binary_op (MODIFY_EXPR, NULL_TREE, orig_dest, src); @@ -746,12 +748,11 @@ build_atomic_store (tree dest, tree src, bool sync) then reinterpret them in the effective type. But if the original type is a padded type with the same size, convert to the inner type instead, as we don't want to artificially introduce a CONSTRUCTOR here. */ - if (TYPE_IS_PADDING_P (TREE_TYPE (dest)) - && TYPE_SIZE (TREE_TYPE (dest)) - == TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (dest))))) - src = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (dest))), src); + if (TYPE_IS_PADDING_P (type) + && TYPE_SIZE (type) == TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (type)))) + src = convert (TREE_TYPE (TYPE_FIELDS (type)), src); else - src = convert (TREE_TYPE (dest), src); + src = convert (type, src); src = fold_build1 (VIEW_CONVERT_EXPR, int_type, src); addr = build_unary_op (ADDR_EXPR, ptr_type, dest); @@ -877,7 +878,8 @@ build_binary_op (enum tree_code op_code, tree result_type, them; we'll be putting them back below if needed. Likewise for conversions between record types, except for justified modular types. But don't do this if the right operand is not BLKmode (for packed - arrays) unless we are not changing the mode. */ + arrays) unless we are not changing the mode, or if both ooperands + are view conversions to the same type. */ while ((CONVERT_EXPR_P (left_operand) || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR) && (((INTEGRAL_TYPE_P (left_type) @@ -889,7 +891,10 @@ build_binary_op (enum tree_code op_code, tree result_type, && TREE_CODE (operand_type (left_operand)) == RECORD_TYPE && (TYPE_MODE (right_type) == BLKmode || TYPE_MODE (left_type) - == TYPE_MODE (operand_type (left_operand)))))) + == TYPE_MODE (operand_type (left_operand))) + && !(TREE_CODE (left_operand) == VIEW_CONVERT_EXPR + && TREE_CODE (right_operand) == VIEW_CONVERT_EXPR + && left_type == right_type)))) { left_operand = TREE_OPERAND (left_operand, 0); left_type = TREE_TYPE (left_operand); @@ -986,7 +991,7 @@ build_binary_op (enum tree_code op_code, tree result_type, break; } - gcc_assert (TREE_CODE (result) == INDIRECT_REF + gcc_assert (INDIRECT_REF_P (result) || TREE_CODE (result) == NULL_EXPR || TREE_CODE (result) == SAVE_EXPR || DECL_P (result)); @@ -1423,7 +1428,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) the corresponding address, e.g. for an allocator. However do it for a return value to expose it for later recognition. */ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE - || (TREE_CODE (TREE_OPERAND (operand, 1)) == VAR_DECL + || (VAR_P (TREE_OPERAND (operand, 1)) && DECL_RETURN_VALUE_P (TREE_OPERAND (operand, 1)))) { result = build_unary_op (ADDR_EXPR, result_type, @@ -1597,11 +1602,11 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) if (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type))) { TREE_SIDE_EFFECTS (result) = 1; - if (TREE_CODE (result) == INDIRECT_REF) + if (INDIRECT_REF_P (result)) TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result)); } - if ((TREE_CODE (result) == INDIRECT_REF + if ((INDIRECT_REF_P (result) || TREE_CODE (result) == UNCONSTRAINED_ARRAY_REF) && can_never_be_null) TREE_THIS_NOTRAP (result) = 1; @@ -2926,7 +2931,7 @@ gnat_protect_expr (tree exp) /* Likewise if we're indirectly referencing part of something. */ if (code == COMPONENT_REF - && TREE_CODE (TREE_OPERAND (exp, 0)) == INDIRECT_REF) + && INDIRECT_REF_P (TREE_OPERAND (exp, 0))) return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)), TREE_OPERAND (exp, 1), NULL_TREE); @@ -3263,7 +3268,7 @@ gnat_invariant_expr (tree expr) /* Look through temporaries created to capture values. */ while ((TREE_CODE (expr) == CONST_DECL - || (TREE_CODE (expr) == VAR_DECL && TREE_READONLY (expr))) + || (VAR_P (expr) && TREE_READONLY (expr))) && decl_function_context (expr) == current_function_decl && DECL_INITIAL (expr)) { @@ -3362,7 +3367,7 @@ object: if (TREE_CODE (t) == PARM_DECL) return fold_convert (type, expr); - if (TREE_CODE (t) == VAR_DECL + if (VAR_P (t) && (DECL_EXTERNAL (t) || decl_function_context (t) != current_function_decl)) return fold_convert (type, expr); |