* *
* C Implementation File *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2019, 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- *
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "target.h"
+#include "tree.h"
+#include "diagnostic.h"
#include "opts.h"
-#include "options.h"
-#include "tm.h"
-#include "hash-set.h"
-#include "machmode.h"
-#include "vec.h"
-#include "double-int.h"
-#include "input.h"
#include "alias.h"
-#include "symtab.h"
-#include "wide-int.h"
-#include "inchash.h"
-#include "tree.h"
#include "fold-const.h"
#include "stor-layout.h"
#include "print-tree.h"
-#include "diagnostic.h"
-#include "target.h"
-#include "ggc.h"
-#include "flags.h"
-#include "debug.h"
#include "toplev.h"
#include "langhooks.h"
#include "langhooks-def.h"
#include "plugin.h"
-#include "real.h"
-#include "hashtab.h"
-#include "hash-set.h"
-#include "vec.h"
-#include "machmode.h"
-#include "hard-reg-set.h"
-#include "input.h"
-#include "function.h" /* For pass_by_reference. */
+#include "calls.h" /* For pass_by_reference. */
#include "dwarf2out.h"
#include "ada.h"
#include "adadecode.h"
#include "types.h"
#include "atree.h"
-#include "elists.h"
#include "namet.h"
#include "nlists.h"
-#include "stringt.h"
#include "uintp.h"
#include "fe.h"
#include "sinfo.h"
unsigned int save_argc;
const char **save_argv;
-/* GNAT argc and argv. */
+/* GNAT argc and argv generated by the binder for all Ada programs. */
extern int gnat_argc;
-extern char **gnat_argv;
+extern const char **gnat_argv;
+
+/* Ada code requires variables for these settings rather than elements
+ of the global_options structure because they are imported. */
+#undef gnat_encodings
+enum dwarf_gnat_encodings gnat_encodings = DWARF_GNAT_ENCODINGS_DEFAULT;
+
+#undef optimize
+int optimize;
+
+#undef optimize_size
+int optimize_size;
+
+#undef flag_short_enums
+int flag_short_enums;
+
+#undef flag_stack_check
+enum stack_check_type flag_stack_check = NO_STACK_CHECK;
#ifdef __cplusplus
extern "C" {
/* ??? Call the SEH initialization routine. This is to workaround
a bootstrap path problem. The call below should be removed at some
- point and the SEH pointer passed to __gnat_initialize() above. */
- __gnat_install_SEH_handler((void *)seh);
+ point and the SEH pointer passed to __gnat_initialize above. */
+ __gnat_install_SEH_handler ((void *)seh);
/* Call the front-end elaboration procedures. */
adainit ();
/* Call the front end. */
_ada_gnat1drv ();
+
+ /* Write the global declarations. */
+ gnat_write_global_declarations ();
}
/* Return language mask for option processing. */
are marked as Ada-specific. Return true on success or false on failure. */
static bool
-gnat_handle_option (size_t scode, const char *arg ATTRIBUTE_UNUSED, int value,
- int kind ATTRIBUTE_UNUSED, location_t loc ATTRIBUTE_UNUSED,
- const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED)
+gnat_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value,
+ int kind, location_t loc,
+ const struct cl_option_handlers *handlers)
{
enum opt_code code = (enum opt_code) scode;
handle_generated_option (&global_options, &global_options_set,
OPT_Wunused, NULL, value,
gnat_option_lang_mask (), kind, loc,
- handlers, global_dc);
+ handlers, true, global_dc);
warn_uninitialized = value;
warn_maybe_uninitialized = value;
break;
/* These are handled by the front-end. */
break;
+ case OPT_fopenacc:
case OPT_fshort_enums:
- /* This is handled by the middle-end. */
+ case OPT_fsigned_char:
+ case OPT_funsigned_char:
+ /* These are handled by the middle-end. */
+ break;
+
+ case OPT_fbuiltin_printf:
+ /* This is ignored in Ada but needs to be accepted so it can be
+ defaulted. */
break;
default:
Ada_handle_option_auto (&global_options, &global_options_set,
scode, arg, value,
- gnat_option_lang_mask (), kind,
- loc, handlers, global_dc);
+ gnat_option_lang_mask (), kind, loc,
+ handlers, global_dc);
return true;
}
??? back_end.adb should not rely on this; instead, it should work with
decoded options without such reparsing, to ensure consistency in how
options are decoded. */
- unsigned int i;
-
save_argv = XNEWVEC (const char *, 2 * decoded_options_count + 1);
save_argc = 0;
- for (i = 0; i < decoded_options_count; i++)
+ for (unsigned int i = 0; i < decoded_options_count; i++)
{
size_t num_elements = decoded_options[i].canonical_option_num_elements;
}
save_argv[save_argc] = NULL;
- gnat_argv = (char **) xmalloc (sizeof (save_argv[0]));
- gnat_argv[0] = xstrdup (save_argv[0]); /* name of the command */
+ /* Pass just the name of the command through the regular channel. */
+ gnat_argv = (const char **) xmalloc (sizeof (char *));
+ gnat_argv[0] = xstrdup (save_argv[0]);
gnat_argc = 1;
}
-/* Ada code requires variables for these settings rather than elements
- of the global_options structure. */
-#undef optimize
-#undef optimize_size
-#undef flag_compare_debug
-#undef flag_short_enums
-#undef flag_stack_check
-int gnat_encodings = 0;
-int optimize;
-int optimize_size;
-int flag_compare_debug;
-int flag_short_enums;
-enum stack_check_type flag_stack_check = NO_STACK_CHECK;
-
/* Settings adjustments after switches processing by the back-end.
Note that the front-end switches processing (Scan_Compiler_Arguments)
has not been done yet at this point! */
gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
{
/* Excess precision other than "fast" requires front-end support. */
- if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD
- && TARGET_FLT_EVAL_METHOD_NON_DEFAULT)
- sorry ("-fexcess-precision=standard for Ada");
+ if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD)
+ sorry ("%<-fexcess-precision=standard%> for Ada");
flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
- /* ??? The warning machinery is outsmarted by Ada. */
- warn_unused_parameter = 0;
-
/* No psABI change warnings for Ada. */
warn_psabi = 0;
+ /* 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 (!global_options_set.x_flag_diagnostics_show_caret)
global_dc->show_caret = false;
+ /* Warn only if STABS is not the default: we don't want to emit a warning if
+ the user did not use a -gstabs option. */
+ if (PREFERRED_DEBUGGING_TYPE != DBX_DEBUG && write_symbols == DBX_DEBUG)
+ warning (0, "STABS debugging information for Ada is obsolete and not "
+ "supported anymore");
+
+ /* Copy global settings to local versions. */
+ gnat_encodings = global_options.x_gnat_encodings;
optimize = global_options.x_optimize;
optimize_size = global_options.x_optimize_size;
- flag_compare_debug = global_options.x_flag_compare_debug;
flag_stack_check = global_options.x_flag_stack_check;
flag_short_enums = global_options.x_flag_short_enums;
/* Here is the function to handle the compiler error processing in GCC. */
static void
-internal_error_function (diagnostic_context *context,
- const char *msgid, va_list *ap)
+internal_error_function (diagnostic_context *context, const char *msgid,
+ va_list *ap)
{
text_info tinfo;
char *buffer, *p, *loc;
sp_loc.Bounds = &temp_loc;
sp_loc.Array = loc;
- Current_Error_Node = error_gnat_node;
Compiler_Abort (sp, sp_loc, true);
}
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. */
- build_common_tree_nodes (flag_signed_char, false);
+ front-end has been run. Use the same `char' as C for Interfaces.C. */
+ build_common_tree_nodes (flag_signed_char);
/* In Ada, we use an unsigned 8-bit type for the default boolean type. */
boolean_type_node = make_unsigned_type (8);
sbitsize_one_node = sbitsize_int (1);
sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT);
- ptr_void_type_node = build_pointer_type (void_type_node);
-
- /* Show that REFERENCE_TYPEs are internal and should be Pmode. */
- internal_reference_types ();
-
/* Register our internal error function. */
global_dc->internal_error = &internal_error_function;
using_eh_for_cleanups ();
/* Turn on -fexceptions, -fnon-call-exceptions and -fdelete-dead-exceptions.
- The first one triggers the generation of the necessary exception tables.
+ The first one activates the support for exceptions in the compiler.
The second one is useful for two reasons: 1/ we map some asynchronous
signals like SEGV to exceptions, so we need to ensure that the insns
which can lead to such signals are correctly attached to the exception
for such calls to actually raise in Ada.
The third one is an optimization that makes it possible to delete dead
instructions that may throw exceptions, most notably loads and stores,
- as permitted in Ada. */
+ as permitted in Ada.
+ Turn off -faggressive-loop-optimizations because it may optimize away
+ out-of-bound array accesses that we want to be able to catch.
+ If checks are disabled, we use the same settings as the C++ compiler,
+ except for the runtime on platforms where S'Machine_Overflow is true
+ because the runtime depends on FP (hardware) checks being properly
+ handled despite being compiled in -gnatp mode. */
flag_exceptions = 1;
- flag_non_call_exceptions = 1;
flag_delete_dead_exceptions = 1;
+ if (Suppress_Checks)
+ {
+ if (!global_options_set.x_flag_non_call_exceptions)
+ flag_non_call_exceptions = Machine_Overflows_On_Target && GNAT_Mode;
+ }
+ else
+ {
+ flag_non_call_exceptions = 1;
+ flag_aggressive_loop_optimizations = 0;
+ warn_aggressive_loop_optimizations = 0;
+ }
init_eh ();
}
switch (TREE_CODE (node))
{
case FUNCTION_TYPE:
+ case METHOD_TYPE:
print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4);
break;
case INTEGER_TYPE:
if (TYPE_MODULAR_P (node))
print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
+ else if (TYPE_FIXED_POINT_P (node))
+ print_node (file, "scale factor", TYPE_SCALE_FACTOR (node),
+ indent + 4);
else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
indent + 4);
default:
break;
}
+
+ if (TYPE_CAN_HAVE_DEBUG_TYPE_P (node) && TYPE_DEBUG_TYPE (node))
+ print_node_brief (file, "debug type", TYPE_DEBUG_TYPE (node), indent + 4);
+
+ if (TYPE_IMPL_PACKED_ARRAY_P (node) && TYPE_ORIGINAL_PACKED_ARRAY (node))
+ print_node_brief (file, "original packed array",
+ TYPE_ORIGINAL_PACKED_ARRAY (node), indent + 4);
}
/* Return the name to be printed for DECL. */
return NULL_TREE;
}
+/* Return the underlying base type of an enumeration type. */
+
+static tree
+gnat_enum_underlying_base_type (const_tree)
+{
+ /* Enumeration types are base types in Ada. */
+ return void_type_node;
+}
+
+/* Return the type to be used for debugging information instead of TYPE or
+ NULL_TREE if TYPE is fine. */
+
+static tree
+gnat_get_debug_type (const_tree type)
+{
+ if (TYPE_CAN_HAVE_DEBUG_TYPE_P (type) && TYPE_DEBUG_TYPE (type))
+ {
+ type = TYPE_DEBUG_TYPE (type);
+
+ /* ??? The get_debug_type language hook is processed after the array
+ descriptor language hook, so if there is an array behind this type,
+ the latter is supposed to handle it. Still, we can get here with
+ a type we are not supposed to handle (e.g. when the DWARF back-end
+ processes the type of a variable), so keep this guard. */
+ if (type && TYPE_CAN_HAVE_DEBUG_TYPE_P (type))
+ return const_cast<tree> (type);
+ }
+
+ return NULL_TREE;
+}
+
+/* Provide information in INFO for debugging output about the TYPE fixed-point
+ type. Return whether TYPE is handled. */
+
+static bool
+gnat_get_fixed_point_type_info (const_tree type,
+ struct fixed_point_type_info *info)
+{
+ tree scale_factor;
+
+ /* GDB cannot handle fixed-point types yet, so rely on GNAT encodings
+ instead for it. */
+ if (!TYPE_IS_FIXED_POINT_P (type)
+ || gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ return false;
+
+ scale_factor = TYPE_SCALE_FACTOR (type);
+
+ /* We expect here only a finite set of pattern. See fixed-point types
+ handling in gnat_to_gnu_entity. */
+
+ /* Put invalid values when compiler internals cannot represent the scale
+ factor. */
+ if (scale_factor == integer_zero_node)
+ {
+ info->scale_factor_kind = fixed_point_scale_factor_arbitrary;
+ info->scale_factor.arbitrary.numerator = 0;
+ info->scale_factor.arbitrary.denominator = 0;
+ return true;
+ }
+
+ if (TREE_CODE (scale_factor) == RDIV_EXPR)
+ {
+ const tree num = TREE_OPERAND (scale_factor, 0);
+ const tree den = TREE_OPERAND (scale_factor, 1);
+
+ /* See if we have a binary or decimal scale. */
+ if (TREE_CODE (den) == POWER_EXPR)
+ {
+ const tree base = TREE_OPERAND (den, 0);
+ const tree exponent = TREE_OPERAND (den, 1);
+
+ /* We expect the scale factor to be 1 / 2 ** N or 1 / 10 ** N. */
+ gcc_assert (num == integer_one_node
+ && TREE_CODE (base) == INTEGER_CST
+ && TREE_CODE (exponent) == INTEGER_CST);
+
+ switch (tree_to_shwi (base))
+ {
+ case 2:
+ info->scale_factor_kind = fixed_point_scale_factor_binary;
+ info->scale_factor.binary = -tree_to_shwi (exponent);
+ return true;
+
+ case 10:
+ info->scale_factor_kind = fixed_point_scale_factor_decimal;
+ info->scale_factor.decimal = -tree_to_shwi (exponent);
+ return true;
+
+ default:
+ gcc_unreachable ();
+ }
+ }
+
+ /* If we reach this point, we are handling an arbitrary scale factor. We
+ expect N / D with constant operands. */
+ gcc_assert (TREE_CODE (num) == INTEGER_CST
+ && TREE_CODE (den) == INTEGER_CST);
+
+ info->scale_factor_kind = fixed_point_scale_factor_arbitrary;
+ info->scale_factor.arbitrary.numerator = tree_to_uhwi (num);
+ info->scale_factor.arbitrary.denominator = tree_to_shwi (den);
+ return true;
+ }
+
+ gcc_unreachable ();
+}
+
/* Return true if types T1 and T2 are identical for type hashing purposes.
Called only after doing all language independent checks. At present,
- this function is only called when both types are FUNCTION_TYPE. */
+ this is only called when both types are FUNCTION_TYPE or METHOD_TYPE. */
static bool
gnat_type_hash_eq (const_tree t1, const_tree t2)
{
- gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE);
+ gcc_assert (FUNC_OR_METHOD_TYPE_P (t1) && TREE_CODE (t1) == TREE_CODE (t2));
return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
TYPE_RETURN_UNCONSTRAINED_P (t2),
TYPE_RETURN_BY_DIRECT_REF_P (t2),
if (TYPE_IS_PADDING_P (type))
return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
+ /* If this is an extra subtype, use the base type. */
+ else if (TYPE_IS_EXTRA_SUBTYPE_P (type))
+ return get_alias_set (get_base_type (type));
+
/* If the type is an unconstrained array, use the type of the
self-referential array we make. */
else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
/* If the type can alias any other types, return the alias set 0. */
else if (TYPE_P (type)
- && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
+ && !TYPE_IS_DUMMY_P (type)
+ && TYPE_UNIVERSAL_ALIASING_P (type))
return 0;
return -1;
/* First see what we can get from TYPE_SIZE_UNIT, which might not
be constant even for simple expressions if it has already been
elaborated and possibly replaced by a VAR_DECL. */
- tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
+ tree max_size_unit = max_size (TYPE_SIZE_UNIT (gnu_type), true);
/* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
which should stay untouched. */
- if (!tree_fits_uhwi_p (max_unitsize)
+ if (!tree_fits_uhwi_p (max_size_unit)
&& RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
&& TYPE_ADA_SIZE (gnu_type))
{
- tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
+ tree max_ada_size = max_size (TYPE_ADA_SIZE (gnu_type), true);
/* If we have succeeded in finding a constant, round it up to the
type's alignment and return the result in units. */
- if (tree_fits_uhwi_p (max_adasize))
- max_unitsize
+ if (tree_fits_uhwi_p (max_ada_size))
+ max_size_unit
= size_binop (CEIL_DIV_EXPR,
- round_up (max_adasize, TYPE_ALIGN (gnu_type)),
+ round_up (max_ada_size, TYPE_ALIGN (gnu_type)),
bitsize_unit_node);
}
- return max_unitsize;
+ return max_size_unit;
}
+static tree get_array_bit_stride (tree);
+
/* Provide information in INFO for debug output about the TYPE array type.
Return whether TYPE is handled. */
static bool
-gnat_get_array_descr_info (const_tree type, struct array_descr_info *info)
+gnat_get_array_descr_info (const_tree const_type,
+ struct array_descr_info *info)
{
bool convention_fortran_p;
- tree index_type;
-
- const_tree dimen = NULL_TREE;
+ bool is_array = false;
+ bool is_fat_ptr = false;
+ bool is_packed_array = false;
+ tree type = const_cast<tree> (const_type);
+ const_tree first_dimen = NULL_TREE;
const_tree last_dimen = NULL_TREE;
+ const_tree dimen;
int i;
- if (TREE_CODE (type) != ARRAY_TYPE
- || !TYPE_DOMAIN (type)
- || !TYPE_INDEX_TYPE (TYPE_DOMAIN (type)))
+ /* Temporaries created in the first pass and used in the second one for thin
+ pointers. The first one is an expression that yields the template record
+ from the base address (i.e. the PLACEHOLDER_EXPR). The second one is just
+ a cursor through this record's fields. */
+ tree thinptr_template_expr = NULL_TREE;
+ tree thinptr_bound_field = NULL_TREE;
+
+ /* ??? See gnat_get_debug_type. */
+ type = maybe_debug_type (type);
+
+ /* If we have an implementation type for a packed array, get the orignial
+ array type. */
+ if (TYPE_IMPL_PACKED_ARRAY_P (type) && TYPE_ORIGINAL_PACKED_ARRAY (type))
+ {
+ type = TYPE_ORIGINAL_PACKED_ARRAY (type);
+ is_packed_array = true;
+ }
+
+ /* First pass: gather all information about this array except everything
+ related to dimensions. */
+
+ /* Only handle ARRAY_TYPE nodes that come from GNAT. */
+ if (TREE_CODE (type) == ARRAY_TYPE
+ && TYPE_DOMAIN (type)
+ && TYPE_INDEX_TYPE (TYPE_DOMAIN (type)))
+ {
+ is_array = true;
+ first_dimen = type;
+ info->data_location = NULL_TREE;
+ }
+
+ else if (TYPE_IS_FAT_POINTER_P (type)
+ && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ {
+ const tree ua_type = TYPE_UNCONSTRAINED_ARRAY (type);
+
+ /* This will be our base object address. */
+ const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
+
+ /* We assume below that maybe_unconstrained_array returns an INDIRECT_REF
+ node. */
+ const tree ua_val
+ = maybe_unconstrained_array (build_unary_op (INDIRECT_REF,
+ ua_type,
+ placeholder_expr));
+
+ is_fat_ptr = true;
+ first_dimen = TREE_TYPE (ua_val);
+
+ /* Get the *address* of the array, not the array itself. */
+ info->data_location = TREE_OPERAND (ua_val, 0);
+ }
+
+ /* Unlike fat pointers (which appear for unconstrained arrays passed in
+ argument), thin pointers are used only for array access types, so we want
+ them to appear in the debug info as pointers to an array type. That's why
+ we match only the RECORD_TYPE here instead of the POINTER_TYPE with the
+ TYPE_IS_THIN_POINTER_P predicate. */
+ else if (TREE_CODE (type) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (type)
+ && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ {
+ /* This will be our base object address. Note that we assume that
+ pointers to these will actually point to the array field (thin
+ pointers are shifted). */
+ const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
+ const tree placeholder_addr
+ = build_unary_op (ADDR_EXPR, NULL_TREE, placeholder_expr);
+
+ const tree bounds_field = TYPE_FIELDS (type);
+ const tree bounds_type = TREE_TYPE (bounds_field);
+ const tree array_field = DECL_CHAIN (bounds_field);
+ const tree array_type = TREE_TYPE (array_field);
+
+ /* Shift the thin pointer address to get the address of the template. */
+ const tree shift_amount
+ = fold_build1 (NEGATE_EXPR, sizetype, byte_position (array_field));
+ tree template_addr
+ = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (placeholder_addr),
+ placeholder_addr, shift_amount);
+ template_addr
+ = fold_convert (TYPE_POINTER_TO (bounds_type), template_addr);
+
+ first_dimen = array_type;
+
+ /* The thin pointer is already the pointer to the array data, so there's
+ no need for a specific "data location" expression. */
+ info->data_location = NULL_TREE;
+
+ thinptr_template_expr = build_unary_op (INDIRECT_REF,
+ bounds_type,
+ template_addr);
+ thinptr_bound_field = TYPE_FIELDS (bounds_type);
+ }
+ else
return false;
- /* Count how many dimentions this array has. */
- for (i = 0, dimen = type; ; ++i, dimen = TREE_TYPE (dimen))
- if (i > 0
- && (TREE_CODE (dimen) != ARRAY_TYPE
- || !TYPE_MULTI_ARRAY_P (dimen)))
- break;
- info->ndimensions = i;
- convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (type);
+ /* Second pass: compute the remaining information: dimensions and
+ corresponding bounds. */
- /* TODO: For row major ordering, we probably want to emit nothing and
+ if (TYPE_PACKED (first_dimen))
+ is_packed_array = true;
+ /* If this array has fortran convention, it's arranged in column-major
+ order, so our view here has reversed dimensions. */
+ convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (first_dimen);
+ /* ??? For row major ordering, we probably want to emit nothing and
instead specify it as the default in Dw_TAG_compile_unit. */
info->ordering = (convention_fortran_p
? array_descr_ordering_column_major
: array_descr_ordering_row_major);
- info->base_decl = NULL_TREE;
- info->data_location = NULL_TREE;
- info->allocated = NULL_TREE;
- info->associated = NULL_TREE;
- for (i = (convention_fortran_p ? info->ndimensions - 1 : 0),
- dimen = type;
+ /* Count how many dimensions this array has. */
+ for (i = 0, dimen = first_dimen; ; ++i, dimen = TREE_TYPE (dimen))
+ {
+ if (i > 0
+ && (TREE_CODE (dimen) != ARRAY_TYPE
+ || !TYPE_MULTI_ARRAY_P (dimen)))
+ break;
+ last_dimen = dimen;
+ }
+
+ info->ndimensions = i;
+ info->rank = NULL_TREE;
+
+ /* Too many dimensions? Give up generating proper description: yield instead
+ nested arrays. Note that in this case, this hook is invoked once on each
+ intermediate array type: be consistent and output nested arrays for all
+ dimensions. */
+ if (info->ndimensions > DWARF2OUT_ARRAY_DESCR_INFO_MAX_DIMEN
+ || TYPE_MULTI_ARRAY_P (first_dimen))
+ {
+ info->ndimensions = 1;
+ last_dimen = first_dimen;
+ }
- 0 <= i && i < info->ndimensions;
+ info->element_type = TREE_TYPE (last_dimen);
+ /* Now iterate over all dimensions in source-order and fill the info
+ structure. */
+ for (i = (convention_fortran_p ? info->ndimensions - 1 : 0),
+ dimen = first_dimen;
+ IN_RANGE (i, 0, info->ndimensions - 1);
i += (convention_fortran_p ? -1 : 1),
dimen = TREE_TYPE (dimen))
{
/* We are interested in the stored bounds for the debug info. */
- index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (dimen));
+ tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (dimen));
- info->dimen[i].bounds_type = index_type;
- info->dimen[i].lower_bound = TYPE_MIN_VALUE (index_type);
- info->dimen[i].upper_bound = TYPE_MAX_VALUE (index_type);
- last_dimen = dimen;
+ if (is_array || is_fat_ptr)
+ {
+ /* GDB does not handle very well the self-referencial bound
+ expressions we are able to generate here for XUA types (they are
+ used only by XUP encodings) so avoid them in this case. Note that
+ there are two cases where we generate self-referencial bound
+ expressions: arrays that are constrained by record discriminants
+ and XUA types. */
+ if (TYPE_CONTEXT (first_dimen)
+ && TREE_CODE (TYPE_CONTEXT (first_dimen)) != RECORD_TYPE
+ && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (index_type))
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ {
+ info->dimen[i].lower_bound = NULL_TREE;
+ info->dimen[i].upper_bound = NULL_TREE;
+ }
+ else
+ {
+ info->dimen[i].lower_bound
+ = maybe_character_value (TYPE_MIN_VALUE (index_type));
+ info->dimen[i].upper_bound
+ = maybe_character_value (TYPE_MAX_VALUE (index_type));
+ }
+ }
+
+ /* This is a thin pointer. */
+ else
+ {
+ info->dimen[i].lower_bound
+ = build_component_ref (thinptr_template_expr, thinptr_bound_field,
+ false);
+ thinptr_bound_field = DECL_CHAIN (thinptr_bound_field);
+
+ info->dimen[i].upper_bound
+ = build_component_ref (thinptr_template_expr, thinptr_bound_field,
+ false);
+ thinptr_bound_field = DECL_CHAIN (thinptr_bound_field);
+ }
+
+ /* The DWARF back-end will output BOUNDS_TYPE as the base type of
+ the array index, so get to the base type of INDEX_TYPE. */
+ while (TREE_TYPE (index_type))
+ index_type = TREE_TYPE (index_type);
+
+ info->dimen[i].bounds_type = maybe_debug_type (index_type);
+ info->dimen[i].stride = NULL_TREE;
}
- info->element_type = TREE_TYPE (last_dimen);
+ /* These are Fortran-specific fields. They make no sense here. */
+ info->allocated = NULL_TREE;
+ info->associated = NULL_TREE;
+
+ if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ {
+ /* When arrays contain dynamically-sized elements, we usually wrap them
+ in padding types, or we create constrained types for them. Then, if
+ such types are stripped in the debugging information output, the
+ debugger needs a way to know the size that is reserved for each
+ element. This is why we emit a stride in such situations. */
+ tree source_element_type = info->element_type;
+
+ while (true)
+ {
+ if (TYPE_DEBUG_TYPE (source_element_type))
+ source_element_type = TYPE_DEBUG_TYPE (source_element_type);
+ else if (TYPE_IS_PADDING_P (source_element_type))
+ source_element_type
+ = TREE_TYPE (TYPE_FIELDS (source_element_type));
+ else
+ break;
+ }
+
+ if (TREE_CODE (TYPE_SIZE_UNIT (source_element_type)) != INTEGER_CST)
+ {
+ info->stride = TYPE_SIZE_UNIT (info->element_type);
+ info->stride_in_bits = false;
+ }
+
+ /* We need to specify a bit stride when it does not correspond to the
+ natural size of the contained elements. ??? Note that we do not
+ support packed records and nested packed arrays. */
+ else if (is_packed_array)
+ {
+ info->stride = get_array_bit_stride (info->element_type);
+ info->stride_in_bits = true;
+ }
+ }
return true;
}
+/* Given the component type COMP_TYPE of a packed array, return an expression
+ that computes the bit stride of this packed array. Return NULL_TREE when
+ unsuccessful. */
+
+static tree
+get_array_bit_stride (tree comp_type)
+{
+ struct array_descr_info info;
+ tree stride;
+
+ /* Simple case: the array contains an integral type: return its RM size. */
+ if (INTEGRAL_TYPE_P (comp_type))
+ return TYPE_RM_SIZE (comp_type);
+
+ /* Otherwise, see if this is an array we can analyze; if it's not, punt. */
+ memset (&info, 0, sizeof (info));
+ if (!gnat_get_array_descr_info (comp_type, &info) || !info.stride)
+ return NULL_TREE;
+
+ /* Otherwise, the array stride is the inner array's stride multiplied by the
+ number of elements it contains. Note that if the inner array is not
+ packed, then the stride is "natural" and thus does not deserve an
+ attribute. */
+ stride = info.stride;
+ if (!info.stride_in_bits)
+ {
+ stride = fold_convert (bitsizetype, stride);
+ stride = build_binary_op (MULT_EXPR, bitsizetype,
+ stride, build_int_cst (bitsizetype, 8));
+ }
+
+ for (int i = 0; i < info.ndimensions; ++i)
+ {
+ tree count;
+
+ if (!info.dimen[i].lower_bound || !info.dimen[i].upper_bound)
+ return NULL_TREE;
+
+ /* Put in count an expression that computes the length of this
+ dimension. */
+ count = build_binary_op (MINUS_EXPR, sbitsizetype,
+ fold_convert (sbitsizetype,
+ info.dimen[i].upper_bound),
+ fold_convert (sbitsizetype,
+ info.dimen[i].lower_bound)),
+ count = build_binary_op (PLUS_EXPR, sbitsizetype,
+ count, build_int_cst (sbitsizetype, 1));
+ count = build_binary_op (MAX_EXPR, sbitsizetype,
+ count,
+ build_int_cst (sbitsizetype, 0));
+ count = fold_convert (bitsizetype, count);
+ stride = build_binary_op (MULT_EXPR, bitsizetype, stride, count);
+ }
+
+ return stride;
+}
+
/* GNU_TYPE is a subtype of an integral type. Set LOWVAL to the low bound
and HIGHVAL to the high bound, respectively. */
*highval = TYPE_MAX_VALUE (gnu_type);
}
+/* Return the bias of GNU_TYPE, if any. */
+
+static tree
+gnat_get_type_bias (const_tree gnu_type)
+{
+ if (TREE_CODE (gnu_type) == INTEGER_TYPE
+ && TYPE_BIASED_REPRESENTATION_P (gnu_type)
+ && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ return TYPE_RM_MIN_VALUE (gnu_type);
+
+ return NULL_TREE;
+}
+
/* GNU_TYPE is the type of a subprogram parameter. Determine if it should be
passed by reference by default. */
is an In Out parameter, but it's probably best to err on the side of
passing more things by reference. */
- if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, true))
+ if (AGGREGATE_TYPE_P (gnu_type)
+ && (!valid_constant_size_p (TYPE_SIZE_UNIT (gnu_type))
+ || compare_tree_int (TYPE_SIZE_UNIT (gnu_type),
+ TYPE_ALIGN (gnu_type)) > 0))
return true;
- if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
+ if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, true))
return true;
- if (AGGREGATE_TYPE_P (gnu_type)
- && (!valid_constant_size_p (TYPE_SIZE_UNIT (gnu_type))
- || 0 < compare_tree_int (TYPE_SIZE_UNIT (gnu_type),
- TYPE_ALIGN (gnu_type))))
+ if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
return true;
return false;
|| fmt == &ieee_extended_intel_96_format
|| fmt == &ieee_extended_intel_96_round_53_format
|| fmt == &ieee_extended_intel_128_format)
- fp_arith_may_widen = true;
+ {
+#ifdef TARGET_FPMATH_DEFAULT
+ if (TARGET_FPMATH_DEFAULT == FPMATH_387)
+#endif
+ fp_arith_may_widen = true;
+ }
if (fmt->b == 2)
digs = (fmt->p - 1) * 1233 / 4096; /* scale by log (2) */
digs = fmt->p;
else
- gcc_unreachable();
+ gcc_unreachable ();
}
/* First register any C types for this mode that the front end
}
/* If no predefined C types were found, register the mode itself. */
- if (!skip_p)
+ int nunits, precision, bitsize;
+ if (!skip_p
+ && GET_MODE_NUNITS (i).is_constant (&nunits)
+ && GET_MODE_PRECISION (i).is_constant (&precision)
+ && GET_MODE_BITSIZE (i).is_constant (&bitsize))
f (GET_MODE_NAME (i), digs, complex_p,
- vector_p ? GET_MODE_NUNITS (i) : 0, float_rep,
- GET_MODE_PRECISION (i), GET_MODE_BITSIZE (i),
- GET_MODE_ALIGNMENT (i));
+ vector_p ? nunits : 0, float_rep,
+ precision, bitsize, GET_MODE_ALIGNMENT (i));
}
}
int
fp_prec_to_size (int prec)
{
- machine_mode mode;
+ opt_scalar_float_mode opt_mode;
- for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
- mode = GET_MODE_WIDER_MODE (mode))
- if (GET_MODE_PRECISION (mode) == prec)
- return GET_MODE_BITSIZE (mode);
+ FOR_EACH_MODE_IN_CLASS (opt_mode, MODE_FLOAT)
+ {
+ scalar_float_mode mode = opt_mode.require ();
+ if (GET_MODE_PRECISION (mode) == prec)
+ return GET_MODE_BITSIZE (mode);
+ }
gcc_unreachable ();
}
int
fp_size_to_prec (int size)
{
- machine_mode mode;
+ opt_scalar_float_mode opt_mode;
- for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
- mode = GET_MODE_WIDER_MODE (mode))
- if (GET_MODE_BITSIZE (mode) == size)
- return GET_MODE_PRECISION (mode);
+ FOR_EACH_MODE_IN_CLASS (opt_mode, MODE_FLOAT)
+ {
+ scalar_mode mode = opt_mode.require ();
+ if (GET_MODE_BITSIZE (mode) == size)
+ return GET_MODE_PRECISION (mode);
+ }
gcc_unreachable ();
}
MARK_TS_TYPED (NULL_EXPR);
MARK_TS_TYPED (PLUS_NOMOD_EXPR);
MARK_TS_TYPED (MINUS_NOMOD_EXPR);
+ MARK_TS_TYPED (POWER_EXPR);
MARK_TS_TYPED (ATTR_ADDR_EXPR);
MARK_TS_TYPED (STMT_STMT);
MARK_TS_TYPED (LOOP_STMT);
MARK_TS_TYPED (EXIT_STMT);
}
+/* Return the size of a tree with CODE, which is a language-specific tree code
+ in category tcc_constant, tcc_exceptional or tcc_type. The default expects
+ never to be called. */
+
+static size_t
+gnat_tree_size (enum tree_code code)
+{
+ gcc_checking_assert (code >= NUM_TREE_CODES);
+ switch (code)
+ {
+ case UNCONSTRAINED_ARRAY_TYPE:
+ return sizeof (tree_type_non_common);
+ default:
+ gcc_unreachable ();
+ }
+}
+
+/* Return the lang specific structure attached to NODE. Allocate it (cleared)
+ if needed. */
+
+struct lang_type *
+get_lang_specific (tree node)
+{
+ if (!TYPE_LANG_SPECIFIC (node))
+ TYPE_LANG_SPECIFIC (node) = ggc_cleared_alloc<struct lang_type> ();
+ return TYPE_LANG_SPECIFIC (node);
+}
+
/* Definitions for our language-specific hooks. */
#undef LANG_HOOKS_NAME
#define LANG_HOOKS_NAME "GNU Ada"
#undef LANG_HOOKS_IDENTIFIER_SIZE
#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
+#undef LANG_HOOKS_TREE_SIZE
+#define LANG_HOOKS_TREE_SIZE gnat_tree_size
#undef LANG_HOOKS_INIT
#define LANG_HOOKS_INIT gnat_init
#undef LANG_HOOKS_OPTION_LANG_MASK
#undef LANG_HOOKS_TYPE_HASH_EQ
#define LANG_HOOKS_TYPE_HASH_EQ gnat_type_hash_eq
#undef LANG_HOOKS_GETDECLS
-#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v
+#define LANG_HOOKS_GETDECLS hook_tree_void_null
#undef LANG_HOOKS_PUSHDECL
#define LANG_HOOKS_PUSHDECL gnat_return_tree
-#undef LANG_HOOKS_WRITE_GLOBALS
-#define LANG_HOOKS_WRITE_GLOBALS gnat_write_global_declarations
+#undef LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL
+#define LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL hook_bool_const_tree_false
#undef LANG_HOOKS_GET_ALIAS_SET
#define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set
#undef LANG_HOOKS_PRINT_DECL
#define LANG_HOOKS_GET_ARRAY_DESCR_INFO gnat_get_array_descr_info
#undef LANG_HOOKS_GET_SUBRANGE_BOUNDS
#define LANG_HOOKS_GET_SUBRANGE_BOUNDS gnat_get_subrange_bounds
+#undef LANG_HOOKS_GET_TYPE_BIAS
+#define LANG_HOOKS_GET_TYPE_BIAS gnat_get_type_bias
#undef LANG_HOOKS_DESCRIPTIVE_TYPE
#define LANG_HOOKS_DESCRIPTIVE_TYPE gnat_descriptive_type
+#undef LANG_HOOKS_ENUM_UNDERLYING_BASE_TYPE
+#define LANG_HOOKS_ENUM_UNDERLYING_BASE_TYPE gnat_enum_underlying_base_type
+#undef LANG_HOOKS_GET_DEBUG_TYPE
+#define LANG_HOOKS_GET_DEBUG_TYPE gnat_get_debug_type
+#undef LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO
+#define LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO gnat_get_fixed_point_type_info
#undef LANG_HOOKS_ATTRIBUTE_TABLE
#define LANG_HOOKS_ATTRIBUTE_TABLE gnat_internal_attribute_table
#undef LANG_HOOKS_BUILTIN_FUNCTION
#define LANG_HOOKS_BUILTIN_FUNCTION gnat_builtin_function
+#undef LANG_HOOKS_INIT_TS
+#define LANG_HOOKS_INIT_TS gnat_init_ts
#undef LANG_HOOKS_EH_PERSONALITY
#define LANG_HOOKS_EH_PERSONALITY gnat_eh_personality
#undef LANG_HOOKS_DEEP_UNSHARING
#define LANG_HOOKS_DEEP_UNSHARING true
-#undef LANG_HOOKS_INIT_TS
-#define LANG_HOOKS_INIT_TS gnat_init_ts
+#undef LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS
+#define LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS true
struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
projects / thirdparty / gcc.git / blobdiff