* *
* C Implementation File *
* *
- * Copyright (C) 1992-2014, 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 "opts.h"
-#include "options.h"
-#include "tm.h"
+#include "target.h"
#include "tree.h"
+#include "diagnostic.h"
+#include "opts.h"
+#include "alias.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 "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;
}
/* Uninitialized really means uninitialized in Ada. */
opts->x_flag_zero_initialized_in_bss = 0;
- /* We can delete dead instructions that may throw exceptions in Ada. */
- opts->x_flag_delete_dead_exceptions = 1;
+ /* We don't care about errno in Ada and it causes __builtin_sqrt to
+ call the libm function rather than do it inline. */
+ opts->x_flag_errno_math = 0;
+ opts->frontend_set_flag_errno_math = true;
}
/* Initialize for option processing. */
??? 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 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;
String_Template temp, temp_loc;
- Fat_Pointer fp, fp_loc;
- expanded_location s;
+ String_Pointer sp, sp_loc;
+ expanded_location xloc;
/* Warn if plugins present. */
warn_if_plugins ();
temp.Low_Bound = 1;
temp.High_Bound = p - buffer;
- fp.Bounds = &temp;
- fp.Array = buffer;
+ sp.Bounds = &temp;
+ sp.Array = buffer;
- s = expand_location (input_location);
- if (context->show_column && s.column != 0)
- asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column);
+ xloc = expand_location (input_location);
+ if (context->show_column && xloc.column != 0)
+ loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column);
else
- asprintf (&loc, "%s:%d", s.file, s.line);
+ loc = xasprintf ("%s:%d", xloc.file, xloc.line);
temp_loc.Low_Bound = 1;
temp_loc.High_Bound = strlen (loc);
- fp_loc.Bounds = &temp_loc;
- fp_loc.Array = loc;
+ sp_loc.Bounds = &temp_loc;
+ sp_loc.Array = loc;
- Current_Error_Node = error_gnat_node;
- Compiler_Abort (fp, -1, fp_loc);
+ Compiler_Abort (sp, sp_loc, true);
}
/* Perform all the initialization steps that are language-specific. */
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;
right exception regions. */
using_eh_for_cleanups ();
- /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
- the generation of the necessary exception tables. 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 region they pertain to,
- 2/ Some calls to pure subprograms are handled as libcall blocks and then
- marked as "cannot trap" if the flag is not set (see emit_libcall_block).
- We should not let this be since it is possible for such calls to actually
- raise in Ada. */
+ /* Turn on -fexceptions, -fnon-call-exceptions and -fdelete-dead-exceptions.
+ 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
+ region they pertain to, 2/ some calls to pure subprograms are handled as
+ libcall blocks and then marked as "cannot trap" if the flag is not set
+ (see emit_libcall_block). We should not let this be since it is possible
+ 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.
+ 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 ();
}
flag_signed_zeros = 0;
/* Assume that FP operations can trap if S'Machine_Overflow is true,
- but don't override the user if not.
-
- ??? Alpha/VMS enables FP traps without declaring it. */
- if (Machine_Overflows_On_Target || TARGET_ABI_OPEN_VMS)
+ but don't override the user if not. */
+ if (Machine_Overflows_On_Target)
flag_trapping_math = 1;
else if (!global_options_set.x_flag_trapping_math)
flag_trapping_math = 0;
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);
- else if (TYPE_VAX_FLOATING_POINT_P (node))
- ;
else
print_node (file, "index type", TYPE_INDEX_TYPE (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 const_type,
+ struct array_descr_info *info)
+{
+ bool convention_fortran_p;
+ 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;
+
+ /* 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;
+
+ /* Second pass: compute the remaining information: dimensions and
+ corresponding bounds. */
+
+ 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);
+
+ /* 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;
+ }
+
+ 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. */
+ tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (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;
+ }
+
+ /* 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
*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;
= { "float", "double", "long double" };
int iloop;
+ /* We are going to compute it below. */
+ fp_arith_may_widen = false;
+
for (iloop = 0; iloop < NUM_MACHINE_MODES; iloop++)
{
- enum machine_mode i = (enum machine_mode) iloop;
- enum machine_mode inner_mode = i;
+ machine_mode i = (machine_mode) iloop;
+ machine_mode inner_mode = i;
bool float_p = false;
bool complex_p = false;
bool vector_p = false;
if (!fmt)
continue;
+ /* Be conservative and consider that floating-point arithmetics may
+ use wider intermediate results as soon as there is an extended
+ Motorola or Intel mode supported by the machine. */
+ if (fmt == &ieee_extended_motorola_format
+ || fmt == &ieee_extended_intel_96_format
+ || fmt == &ieee_extended_intel_96_round_53_format
+ || fmt == &ieee_extended_intel_128_format)
+ {
+#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();
-
- if (fmt == &vax_f_format
- || fmt == &vax_d_format
- || fmt == &vax_g_format)
- float_rep = VAX_Native;
+ 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)
{
- enum 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)
{
- enum 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_TYPE_FOR_SIZE gnat_type_for_size
#undef LANG_HOOKS_TYPES_COMPATIBLE_P
#define LANG_HOOKS_TYPES_COMPATIBLE_P gnat_types_compatible_p
+#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
+#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