gdb/ada-lang.c

/* Ada language support routines for GDB, the GNU debugger.

   Copyright (C) 1992-2024 Free Software Foundation, Inc.

   This file is part of GDB.

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */


#include <ctype.h>
#include "event-top.h"
#include "exceptions.h"
#include "extract-store-integer.h"
#include "gdbsupport/gdb_regex.h"
#include "frame.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "cli/cli-cmds.h"
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
#include "varobj.h"
#include "inferior.h"
#include "symfile.h"
#include "objfiles.h"
#include "breakpoint.h"
#include "gdbcore.h"
#include "hashtab.h"
#include "gdbsupport/gdb_obstack.h"
#include "ada-lang.h"
#include "completer.h"
#include "ui-out.h"
#include "block.h"
#include "infcall.h"
#include "annotate.h"
#include "valprint.h"
#include "source.h"
#include "observable.h"
#include "stack.h"
#include "typeprint.h"
#include "namespace.h"
#include "cli/cli-style.h"
#include "cli/cli-decode.h"

#include "value.h"
#include "mi/mi-common.h"
#include "arch-utils.h"
#include "cli/cli-utils.h"
#include "gdbsupport/function-view.h"
#include "gdbsupport/byte-vector.h"
#include "gdbsupport/selftest.h"
#include <algorithm>
#include "ada-exp.h"
#include "charset.h"
#include "ax-gdb.h"

static struct type *desc_base_type (struct type *);

static struct type *desc_bounds_type (struct type *);

static struct value *desc_bounds (struct value *);

static int fat_pntr_bounds_bitpos (struct type *);

static int fat_pntr_bounds_bitsize (struct type *);

static struct type *desc_data_target_type (struct type *);

static struct value *desc_data (struct value *);

static int fat_pntr_data_bitpos (struct type *);

static int fat_pntr_data_bitsize (struct type *);

static struct value *desc_one_bound (struct value *, int, int);

static int desc_bound_bitpos (struct type *, int, int);

static int desc_bound_bitsize (struct type *, int, int);

static struct type *desc_index_type (struct type *, int);

static int desc_arity (struct type *);

static int ada_args_match (struct symbol *, struct value **, int);

static struct value *make_array_descriptor (struct type *, struct value *);

static void ada_add_block_symbols (std::vector<struct block_symbol> &,
				   const struct block *,
				   const lookup_name_info &lookup_name,
				   domain_search_flags, struct objfile *);

static void ada_add_all_symbols (std::vector<struct block_symbol> &,
				 const struct block *,
				 const lookup_name_info &lookup_name,
				 domain_search_flags, int, int *);

static int is_nonfunction (const std::vector<struct block_symbol> &);

static void add_defn_to_vec (std::vector<struct block_symbol> &,
			     struct symbol *,
			     const struct block *);

static int possible_user_operator_p (enum exp_opcode, struct value **);

static const char *ada_decoded_op_name (enum exp_opcode);

static int numeric_type_p (struct type *);

static int integer_type_p (struct type *);

static int scalar_type_p (struct type *);

static int discrete_type_p (struct type *);

static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
						int, int);

static struct type *ada_find_parallel_type_with_name (struct type *,
						      const char *);

static int is_dynamic_field (struct type *, int);

static struct type *to_fixed_variant_branch_type (struct type *,
						  const gdb_byte *,
						  CORE_ADDR, struct value *);

static struct type *to_fixed_array_type (struct type *, struct value *, int);

static struct type *to_fixed_range_type (struct type *, struct value *);

static struct type *to_static_fixed_type (struct type *);
static struct type *static_unwrap_type (struct type *type);

static struct value *unwrap_value (struct value *);

static struct type *constrained_packed_array_type (struct type *, long *);

static struct type *decode_constrained_packed_array_type (struct type *);

static long decode_packed_array_bitsize (struct type *);

static struct value *decode_constrained_packed_array (struct value *);

static int ada_is_unconstrained_packed_array_type (struct type *);

static struct value *value_subscript_packed (struct value *, int,
					     struct value **);

static struct value *coerce_unspec_val_to_type (struct value *,
						struct type *);

static int lesseq_defined_than (struct symbol *, struct symbol *);

static int equiv_types (struct type *, struct type *);

static int is_name_suffix (const char *);

static int advance_wild_match (const char **, const char *, char);

static bool wild_match (const char *name, const char *patn);

static struct value *ada_coerce_ref (struct value *);

static LONGEST pos_atr (struct value *);

static struct value *val_atr (struct type *, LONGEST);

static struct value *ada_search_struct_field (const char *, struct value *, int,
					      struct type *);

static int find_struct_field (const char *, struct type *, int,
			      struct type **, int *, int *, int *, int *);

static int ada_resolve_function (std::vector<struct block_symbol> &,
				 struct value **, int, const char *,
				 struct type *, bool);

static int ada_is_direct_array_type (struct type *);

static struct value *ada_index_struct_field (int, struct value *, int,
					     struct type *);

static struct type *ada_find_any_type (const char *name);

static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
  (const lookup_name_info &lookup_name);

static int symbols_are_identical_enums
  (const std::vector<struct block_symbol> &syms);

static bool ada_identical_enum_types_p (struct type *type1,
					struct type *type2);


/* The character set used for source files.  */
static const char *ada_source_charset;

/* The string "UTF-8".  This is here so we can check for the UTF-8
   charset using == rather than strcmp.  */
static const char ada_utf8[] = "UTF-8";

/* Each entry in the UTF-32 case-folding table is of this form.  */
struct utf8_entry
{
  /* The start and end, inclusive, of this range of codepoints.  */
  uint32_t start, end;
  /* The delta to apply to get the upper-case form.  0 if this is
     already upper-case.  */
  int upper_delta;
  /* The delta to apply to get the lower-case form.  0 if this is
     already lower-case.  */
  int lower_delta;

  bool operator< (uint32_t val) const
  {
    return end < val;
  }
};

static const utf8_entry ada_case_fold[] =
{
#include "ada-casefold.h"
};



static const char ada_completer_word_break_characters[] =
#ifdef VMS
  " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
#else
  " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
#endif

/* The name of the symbol to use to get the name of the main subprogram.  */
static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
  = "__gnat_ada_main_program_name";

/* Limit on the number of warnings to raise per expression evaluation.  */
static int warning_limit = 2;

/* Number of warning messages issued; reset to 0 by cleanups after
   expression evaluation.  */
static int warnings_issued = 0;

static const char * const known_runtime_file_name_patterns[] = {
  ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
};

static const char * const known_auxiliary_function_name_patterns[] = {
  ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
};

/* Maintenance-related settings for this module.  */

static struct cmd_list_element *maint_set_ada_cmdlist;
static struct cmd_list_element *maint_show_ada_cmdlist;

/* The "maintenance ada set/show ignore-descriptive-type" value.  */

static bool ada_ignore_descriptive_types_p = false;

			/* Inferior-specific data.  */

/* Per-inferior data for this module.  */

struct ada_inferior_data
{
  /* The ada__tags__type_specific_data type, which is used when decoding
     tagged types.  With older versions of GNAT, this type was directly
     accessible through a component ("tsd") in the object tag.  But this
     is no longer the case, so we cache it for each inferior.  */
  struct type *tsd_type = nullptr;

  /* The exception_support_info data.  This data is used to determine
     how to implement support for Ada exception catchpoints in a given
     inferior.  */
  const struct exception_support_info *exception_info = nullptr;
};

/* Our key to this module's inferior data.  */
static const registry<inferior>::key<ada_inferior_data> ada_inferior_data;

/* Return our inferior data for the given inferior (INF).

   This function always returns a valid pointer to an allocated
   ada_inferior_data structure.  If INF's inferior data has not
   been previously set, this functions creates a new one with all
   fields set to zero, sets INF's inferior to it, and then returns
   a pointer to that newly allocated ada_inferior_data.  */

static struct ada_inferior_data *
get_ada_inferior_data (struct inferior *inf)
{
  struct ada_inferior_data *data;

  data = ada_inferior_data.get (inf);
  if (data == NULL)
    data = ada_inferior_data.emplace (inf);

  return data;
}

/* Perform all necessary cleanups regarding our module's inferior data
   that is required after the inferior INF just exited.  */

static void
ada_inferior_exit (struct inferior *inf)
{
  ada_inferior_data.clear (inf);
}


			/* program-space-specific data.  */

/* The result of a symbol lookup to be stored in our symbol cache.  */

struct cache_entry
{
  /* The name used to perform the lookup.  */
  std::string name;
  /* The namespace used during the lookup.  */
  domain_search_flags domain = 0;
  /* The symbol returned by the lookup, or NULL if no matching symbol
     was found.  */
  struct symbol *sym = nullptr;
  /* The block where the symbol was found, or NULL if no matching
     symbol was found.  */
  const struct block *block = nullptr;
};

/* The symbol cache uses this type when searching.  */

struct cache_entry_search
{
  const char *name;
  domain_search_flags domain;

  hashval_t hash () const
  {
    /* This must agree with hash_cache_entry, below.  */
    return htab_hash_string (name);
  }
};

/* Hash function for cache_entry.  */

static hashval_t
hash_cache_entry (const void *v)
{
  const cache_entry *entry = (const cache_entry *) v;
  return htab_hash_string (entry->name.c_str ());
}

/* Equality function for cache_entry.  */

static int
eq_cache_entry (const void *a, const void *b)
{
  const cache_entry *entrya = (const cache_entry *) a;
  const cache_entry_search *entryb = (const cache_entry_search *) b;

  return entrya->domain == entryb->domain && entrya->name == entryb->name;
}

/* Key to our per-program-space data.  */
static const registry<program_space>::key<htab, htab_deleter>
  ada_pspace_data_handle;

/* Return this module's data for the given program space (PSPACE).
   If not is found, add a zero'ed one now.

   This function always returns a valid object.  */

static htab_t
get_ada_pspace_data (struct program_space *pspace)
{
  htab_t data = ada_pspace_data_handle.get (pspace);
  if (data == nullptr)
    {
      data = htab_create_alloc (10, hash_cache_entry, eq_cache_entry,
				htab_delete_entry<cache_entry>,
				xcalloc, xfree);
      ada_pspace_data_handle.set (pspace, data);
    }

  return data;
}

			/* Utilities */

/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
   all typedef layers have been peeled.  Otherwise, return TYPE.

   Normally, we really expect a typedef type to only have 1 typedef layer.
   In other words, we really expect the target type of a typedef type to be
   a non-typedef type.  This is particularly true for Ada units, because
   the language does not have a typedef vs not-typedef distinction.
   In that respect, the Ada compiler has been trying to eliminate as many
   typedef definitions in the debugging information, since they generally
   do not bring any extra information (we still use typedef under certain
   circumstances related mostly to the GNAT encoding).

   Unfortunately, we have seen situations where the debugging information
   generated by the compiler leads to such multiple typedef layers.  For
   instance, consider the following example with stabs:

     .stabs  "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
     .stabs  "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0

   This is an error in the debugging information which causes type
   pck__float_array___XUP to be defined twice, and the second time,
   it is defined as a typedef of a typedef.

   This is on the fringe of legality as far as debugging information is
   concerned, and certainly unexpected.  But it is easy to handle these
   situations correctly, so we can afford to be lenient in this case.  */

static struct type *
ada_typedef_target_type (struct type *type)
{
  while (type->code () == TYPE_CODE_TYPEDEF)
    type = type->target_type ();
  return type;
}

/* Given DECODED_NAME a string holding a symbol name in its
   decoded form (ie using the Ada dotted notation), returns
   its unqualified name.  */

static const char *
ada_unqualified_name (const char *decoded_name)
{
  const char *result;
  
  /* If the decoded name starts with '<', it means that the encoded
     name does not follow standard naming conventions, and thus that
     it is not your typical Ada symbol name.  Trying to unqualify it
     is therefore pointless and possibly erroneous.  */
  if (decoded_name[0] == '<')
    return decoded_name;

  result = strrchr (decoded_name, '.');
  if (result != NULL)
    result++;                   /* Skip the dot...  */
  else
    result = decoded_name;

  return result;
}

/* Return a string starting with '<', followed by STR, and '>'.  */

static std::string
add_angle_brackets (const char *str)
{
  return string_printf ("<%s>", str);
}

/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
   suffix of FIELD_NAME beginning "___".  */

static int
field_name_match (const char *field_name, const char *target)
{
  int len = strlen (target);

  return
    (strncmp (field_name, target, len) == 0
     && (field_name[len] == '\0'
	 || (startswith (field_name + len, "___")
	     && strcmp (field_name + strlen (field_name) - 6,
			"___XVN") != 0)));
}


/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
   a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
   and return its index.  This function also handles fields whose name
   have ___ suffixes because the compiler sometimes alters their name
   by adding such a suffix to represent fields with certain constraints.
   If the field could not be found, return a negative number if
   MAYBE_MISSING is set.  Otherwise raise an error.  */

int
ada_get_field_index (const struct type *type, const char *field_name,
		     int maybe_missing)
{
  int fieldno;
  struct type *struct_type = check_typedef ((struct type *) type);

  for (fieldno = 0; fieldno < struct_type->num_fields (); fieldno++)
    if (field_name_match (struct_type->field (fieldno).name (), field_name))
      return fieldno;

  if (!maybe_missing)
    error (_("Unable to find field %s in struct %s.  Aborting"),
	   field_name, struct_type->name ());

  return -1;
}

/* The length of the prefix of NAME prior to any "___" suffix.  */

int
ada_name_prefix_len (const char *name)
{
  if (name == NULL)
    return 0;
  else
    {
      const char *p = strstr (name, "___");

      if (p == NULL)
	return strlen (name);
      else
	return p - name;
    }
}

/* Return non-zero if SUFFIX is a suffix of STR.
   Return zero if STR is null.  */

static int
is_suffix (const char *str, const char *suffix)
{
  int len1, len2;

  if (str == NULL)
    return 0;
  len1 = strlen (str);
  len2 = strlen (suffix);
  return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
}

/* The contents of value VAL, treated as a value of type TYPE.  The
   result is an lval in memory if VAL is.  */

static struct value *
coerce_unspec_val_to_type (struct value *val, struct type *type)
{
  type = ada_check_typedef (type);
  if (val->type () == type)
    return val;
  else
    {
      struct value *result;

      if (val->optimized_out ())
	result = value::allocate_optimized_out (type);
      else if (val->lazy ()
	       /* Be careful not to make a lazy not_lval value.  */
	       || (val->lval () != not_lval
		   && type->length () > val->type ()->length ()))
	result = value::allocate_lazy (type);
      else
	{
	  result = value::allocate (type);
	  val->contents_copy (result, 0, 0, type->length ());
	}
      result->set_component_location (val);
      result->set_bitsize (val->bitsize ());
      result->set_bitpos (val->bitpos ());
      if (result->lval () == lval_memory)
	result->set_address (val->address ());
      return result;
    }
}

static const gdb_byte *
cond_offset_host (const gdb_byte *valaddr, long offset)
{
  if (valaddr == NULL)
    return NULL;
  else
    return valaddr + offset;
}

static CORE_ADDR
cond_offset_target (CORE_ADDR address, long offset)
{
  if (address == 0)
    return 0;
  else
    return address + offset;
}

/* Issue a warning (as for the definition of warning in utils.c, but
   with exactly one argument rather than ...), unless the limit on the
   number of warnings has passed during the evaluation of the current
   expression.  */

/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
   provided by "complaint".  */
static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);

static void
lim_warning (const char *format, ...)
{
  va_list args;

  va_start (args, format);
  warnings_issued += 1;
  if (warnings_issued <= warning_limit)
    vwarning (format, args);

  va_end (args);
}

/* Maximum value of a SIZE-byte signed integer type.  */
static LONGEST
max_of_size (int size)
{
  LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);

  return top_bit | (top_bit - 1);
}

/* Minimum value of a SIZE-byte signed integer type.  */
static LONGEST
min_of_size (int size)
{
  return -max_of_size (size) - 1;
}

/* Maximum value of a SIZE-byte unsigned integer type.  */
static ULONGEST
umax_of_size (int size)
{
  ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);

  return top_bit | (top_bit - 1);
}

/* Maximum value of integral type T, as a signed quantity.  */
static LONGEST
max_of_type (struct type *t)
{
  if (t->is_unsigned ())
    return (LONGEST) umax_of_size (t->length ());
  else
    return max_of_size (t->length ());
}

/* Minimum value of integral type T, as a signed quantity.  */
static LONGEST
min_of_type (struct type *t)
{
  if (t->is_unsigned ())
    return 0;
  else
    return min_of_size (t->length ());
}

/* The largest value in the domain of TYPE, a discrete type, as an integer.  */
LONGEST
ada_discrete_type_high_bound (struct type *type)
{
  type = resolve_dynamic_type (type, {}, 0);
  switch (type->code ())
    {
    case TYPE_CODE_RANGE:
      {
	const dynamic_prop &high = type->bounds ()->high;

	if (high.is_constant ())
	  return high.const_val ();
	else
	  {
	    gdb_assert (!high.is_available ());

	    /* This happens when trying to evaluate a type's dynamic bound
	       without a live target.  There is nothing relevant for us to
	       return here, so return 0.  */
	    return 0;
	  }
      }
    case TYPE_CODE_ENUM:
      return type->field (type->num_fields () - 1).loc_enumval ();
    case TYPE_CODE_BOOL:
      return 1;
    case TYPE_CODE_CHAR:
    case TYPE_CODE_INT:
      return max_of_type (type);
    default:
      error (_("Unexpected type in ada_discrete_type_high_bound."));
    }
}

/* The smallest value in the domain of TYPE, a discrete type, as an integer.  */
LONGEST
ada_discrete_type_low_bound (struct type *type)
{
  type = resolve_dynamic_type (type, {}, 0);
  switch (type->code ())
    {
    case TYPE_CODE_RANGE:
      {
	const dynamic_prop &low = type->bounds ()->low;

	if (low.is_constant ())
	  return low.const_val ();
	else
	  {
	    gdb_assert (!low.is_available ());

	    /* This happens when trying to evaluate a type's dynamic bound
	       without a live target.  There is nothing relevant for us to
	       return here, so return 0.  */
	    return 0;
	  }
      }
    case TYPE_CODE_ENUM:
      return type->field (0).loc_enumval ();
    case TYPE_CODE_BOOL:
      return 0;
    case TYPE_CODE_CHAR:
    case TYPE_CODE_INT:
      return min_of_type (type);
    default:
      error (_("Unexpected type in ada_discrete_type_low_bound."));
    }
}

/* The identity on non-range types.  For range types, the underlying
   non-range scalar type.  */

static struct type *
get_base_type (struct type *type)
{
  while (type != NULL && type->code () == TYPE_CODE_RANGE)
    {
      if (type == type->target_type () || type->target_type () == NULL)
	return type;
      type = type->target_type ();
    }
  return type;
}

/* Return a decoded version of the given VALUE.  This means returning
   a value whose type is obtained by applying all the GNAT-specific
   encodings, making the resulting type a static but standard description
   of the initial type.  */

struct value *
ada_get_decoded_value (struct value *value)
{
  struct type *type = ada_check_typedef (value->type ());

  if (ada_is_array_descriptor_type (type)
      || (ada_is_constrained_packed_array_type (type)
	  && type->code () != TYPE_CODE_PTR))
    {
      if (type->code () == TYPE_CODE_TYPEDEF)  /* array access type.  */
	value = ada_coerce_to_simple_array_ptr (value);
      else
	value = ada_coerce_to_simple_array (value);
    }
  else
    value = ada_to_fixed_value (value);

  return value;
}

/* Same as ada_get_decoded_value, but with the given TYPE.
   Because there is no associated actual value for this type,
   the resulting type might be a best-effort approximation in
   the case of dynamic types.  */

struct type *
ada_get_decoded_type (struct type *type)
{
  type = to_static_fixed_type (type);
  if (ada_is_constrained_packed_array_type (type))
    type = ada_coerce_to_simple_array_type (type);
  return type;
}



				/* Language Selection */

/* If the main procedure is written in Ada, then return its name.
   The result is good until the next call.  Return NULL if the main
   procedure doesn't appear to be in Ada.  */

const char *
ada_main_name ()
{
  static gdb::unique_xmalloc_ptr<char> main_program_name;

  /* For Ada, the name of the main procedure is stored in a specific
     string constant, generated by the binder.  Look for that symbol,
     extract its address, and then read that string.  If we didn't find
     that string, then most probably the main procedure is not written
     in Ada.  */
  bound_minimal_symbol msym
    = lookup_minimal_symbol (current_program_space,
			     ADA_MAIN_PROGRAM_SYMBOL_NAME);

  if (msym.minsym != NULL)
    {
      CORE_ADDR main_program_name_addr = msym.value_address ();
      if (main_program_name_addr == 0)
	error (_("Invalid address for Ada main program name."));

      /* Force trust_readonly, because we always want to fetch this
	 string from the executable, not from inferior memory.  If the
	 user changes the exec-file and invokes "start", we want to
	 pick the "main" from the new executable, not one that may
	 come from the still-live inferior.  */
      scoped_restore save_trust_readonly
	= make_scoped_restore (&trust_readonly, true);
      main_program_name = target_read_string (main_program_name_addr, 1024);
      return main_program_name.get ();
    }

  /* The main procedure doesn't seem to be in Ada.  */
  return NULL;
}

				/* Symbols */

/* Table of Ada operators and their GNAT-encoded names.  Last entry is pair
   of NULLs.  */

const struct ada_opname_map ada_opname_table[] = {
  {"Oadd", "\"+\"", BINOP_ADD},
  {"Osubtract", "\"-\"", BINOP_SUB},
  {"Omultiply", "\"*\"", BINOP_MUL},
  {"Odivide", "\"/\"", BINOP_DIV},
  {"Omod", "\"mod\"", BINOP_MOD},
  {"Orem", "\"rem\"", BINOP_REM},
  {"Oexpon", "\"**\"", BINOP_EXP},
  {"Olt", "\"<\"", BINOP_LESS},
  {"Ole", "\"<=\"", BINOP_LEQ},
  {"Ogt", "\">\"", BINOP_GTR},
  {"Oge", "\">=\"", BINOP_GEQ},
  {"Oeq", "\"=\"", BINOP_EQUAL},
  {"One", "\"/=\"", BINOP_NOTEQUAL},
  {"Oand", "\"and\"", BINOP_BITWISE_AND},
  {"Oor", "\"or\"", BINOP_BITWISE_IOR},
  {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
  {"Oconcat", "\"&\"", BINOP_CONCAT},
  {"Oabs", "\"abs\"", UNOP_ABS},
  {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
  {"Oadd", "\"+\"", UNOP_PLUS},
  {"Osubtract", "\"-\"", UNOP_NEG},
  {NULL, NULL}
};

/* If STR is a decoded version of a compiler-provided suffix (like the
   "[cold]" in "symbol[cold]"), return true.  Otherwise, return
   false.  */

static bool
is_compiler_suffix (const char *str)
{
  gdb_assert (*str == '[');
  ++str;
  while (*str != '\0' && isalpha (*str))
    ++str;
  /* We accept a missing "]" in order to support completion.  */
  return *str == '\0' || (str[0] == ']' && str[1] == '\0');
}

/* Append a non-ASCII character to RESULT.  */
static void
append_hex_encoded (std::string &result, uint32_t one_char)
{
  if (one_char <= 0xff)
    {
      result.append ("U");
      result.append (phex (one_char, 1));
    }
  else if (one_char <= 0xffff)
    {
      result.append ("W");
      result.append (phex (one_char, 2));
    }
  else
    {
      result.append ("WW");
      result.append (phex (one_char, 4));
    }
}

/* Return a string that is a copy of the data in STORAGE, with
   non-ASCII characters replaced by the appropriate hex encoding.  A
   template is used because, for UTF-8, we actually want to work with
   UTF-32 codepoints.  */
template<typename T>
std::string
copy_and_hex_encode (struct obstack *storage)
{
  const T *chars = (T *) obstack_base (storage);
  int num_chars = obstack_object_size (storage) / sizeof (T);
  std::string result;
  for (int i = 0; i < num_chars; ++i)
    {
      if (chars[i] <= 0x7f)
	{
	  /* The host character set has to be a superset of ASCII, as
	     are all the other character sets we can use.  */
	  result.push_back (chars[i]);
	}
      else
	append_hex_encoded (result, chars[i]);
    }
  return result;
}

/* The "encoded" form of DECODED, according to GNAT conventions.  If
   THROW_ERRORS, throw an error if invalid operator name is found.
   Otherwise, return the empty string in that case.  */

static std::string
ada_encode_1 (const char *decoded, bool throw_errors)
{
  if (decoded == NULL)
    return {};

  std::string encoding_buffer;
  bool saw_non_ascii = false;
  for (const char *p = decoded; *p != '\0'; p += 1)
    {
      if ((*p & 0x80) != 0)
	saw_non_ascii = true;

      if (*p == '.')
	encoding_buffer.append ("__");
      else if (*p == '[' && is_compiler_suffix (p))
	{
	  encoding_buffer = encoding_buffer + "." + (p + 1);
	  if (encoding_buffer.back () == ']')
	    encoding_buffer.pop_back ();
	  break;
	}
      else if (*p == '"')
	{
	  const struct ada_opname_map *mapping;

	  for (mapping = ada_opname_table;
	       mapping->encoded != NULL
	       && !startswith (p, mapping->decoded); mapping += 1)
	    ;
	  if (mapping->encoded == NULL)
	    {
	      if (throw_errors)
		error (_("invalid Ada operator name: %s"), p);
	      else
		return {};
	    }
	  encoding_buffer.append (mapping->encoded);
	  break;
	}
      else
	encoding_buffer.push_back (*p);
    }

  /* If a non-ASCII character is seen, we must convert it to the
     appropriate hex form.  As this is more expensive, we keep track
     of whether it is even necessary.  */
  if (saw_non_ascii)
    {
      auto_obstack storage;
      bool is_utf8 = ada_source_charset == ada_utf8;
      try
	{
	  convert_between_encodings
	    (host_charset (),
	     is_utf8 ? HOST_UTF32 : ada_source_charset,
	     (const gdb_byte *) encoding_buffer.c_str (),
	     encoding_buffer.length (), 1,
	     &storage, translit_none);
	}
      catch (const gdb_exception &)
	{
	  static bool warned = false;

	  /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
	     might like to know why.  */
	  if (!warned)
	    {
	      warned = true;
	      warning (_("charset conversion failure for '%s'.\n"
			 "You may have the wrong value for 'set ada source-charset'."),
		       encoding_buffer.c_str ());
	    }

	  /* We don't try to recover from errors.  */
	  return encoding_buffer;
	}

      if (is_utf8)
	return copy_and_hex_encode<uint32_t> (&storage);
      return copy_and_hex_encode<gdb_byte> (&storage);
    }

  return encoding_buffer;
}

/* Find the entry for C in the case-folding table.  Return nullptr if
   the entry does not cover C.  */
static const utf8_entry *
find_case_fold_entry (uint32_t c)
{
  auto iter = std::lower_bound (std::begin (ada_case_fold),
				std::end (ada_case_fold),
				c);
  if (iter == std::end (ada_case_fold)
      || c < iter->start
      || c > iter->end)
    return nullptr;
  return &*iter;
}

/* Return NAME folded to lower case, or, if surrounded by single
   quotes, unfolded, but with the quotes stripped away.  If
   THROW_ON_ERROR is true, encoding failures will throw an exception
   rather than emitting a warning.  Result good to next call.  */

static const char *
ada_fold_name (std::string_view name, bool throw_on_error = false)
{
  static std::string fold_storage;

  if (!name.empty () && name[0] == '\'')
    fold_storage = name.substr (1, name.size () - 2);
  else
    {
      /* Why convert to UTF-32 and implement our own case-folding,
	 rather than convert to wchar_t and use the platform's
	 functions?  I'm glad you asked.

	 The main problem is that GNAT implements an unusual rule for
	 case folding.  For ASCII letters, letters in single-byte
	 encodings (such as ISO-8859-*), and Unicode letters that fit
	 in a single byte (i.e., code point is <= 0xff), the letter is
	 folded to lower case.  Other Unicode letters are folded to
	 upper case.

	 This rule means that the code must be able to examine the
	 value of the character.  And, some hosts do not use Unicode
	 for wchar_t, so examining the value of such characters is
	 forbidden.  */
      auto_obstack storage;
      try
	{
	  convert_between_encodings
	    (host_charset (), HOST_UTF32,
	     (const gdb_byte *) name.data (),
	     name.length (), 1,
	     &storage, translit_none);
	}
      catch (const gdb_exception &)
	{
	  if (throw_on_error)
	    throw;

	  static bool warned = false;

	  /* Converting to UTF-32 shouldn't fail, so if it doesn't, we
	     might like to know why.  */
	  if (!warned)
	    {
	      warned = true;
	      warning (_("could not convert '%s' from the host encoding (%s) to UTF-32.\n"
			 "This normally should not happen, please file a bug report."),
		       std::string (name).c_str (), host_charset ());
	    }

	  /* We don't try to recover from errors; just return the
	     original string.  */
	  fold_storage = name;
	  return fold_storage.c_str ();
	}

      bool is_utf8 = ada_source_charset == ada_utf8;
      uint32_t *chars = (uint32_t *) obstack_base (&storage);
      int num_chars = obstack_object_size (&storage) / sizeof (uint32_t);
      for (int i = 0; i < num_chars; ++i)
	{
	  const struct utf8_entry *entry = find_case_fold_entry (chars[i]);
	  if (entry != nullptr)
	    {
	      uint32_t low = chars[i] + entry->lower_delta;
	      if (!is_utf8 || low <= 0xff)
		chars[i] = low;
	      else
		chars[i] = chars[i] + entry->upper_delta;
	    }
	}

      /* Now convert back to ordinary characters.  */
      auto_obstack reconverted;
      try
	{
	  convert_between_encodings (HOST_UTF32,
				     host_charset (),
				     (const gdb_byte *) chars,
				     num_chars * sizeof (uint32_t),
				     sizeof (uint32_t),
				     &reconverted,
				     translit_none);
	  obstack_1grow (&reconverted, '\0');
	  fold_storage = std::string ((const char *) obstack_base (&reconverted));
	}
      catch (const gdb_exception &)
	{
	  if (throw_on_error)
	    throw;

	  static bool warned = false;

	  /* Converting back from UTF-32 shouldn't normally fail, but
	     there are some host encodings without upper/lower
	     equivalence.  */
	  if (!warned)
	    {
	      warned = true;
	      warning (_("could not convert the lower-cased variant of '%s'\n"
			 "from UTF-32 to the host encoding (%s)."),
		       std::string (name).c_str (), host_charset ());
	    }

	  /* We don't try to recover from errors; just return the
	     original string.  */
	  fold_storage = name;
	}
    }

  return fold_storage.c_str ();
}

/* The "encoded" form of DECODED, according to GNAT conventions.  If
   FOLD is true (the default), case-fold any ordinary symbol.  Symbols
   with <...> quoting are not folded in any case.  */

std::string
ada_encode (const char *decoded, bool fold)
{
  if (fold && decoded[0] != '<')
    decoded = ada_fold_name (decoded);
  return ada_encode_1 (decoded, true);
}

/* Return nonzero if C is either a digit or a lowercase alphabet character.  */

static int
is_lower_alphanum (const char c)
{
  return (isdigit (c) || (isalpha (c) && islower (c)));
}

/* ENCODED is the linkage name of a symbol and LEN contains its length.
   This function saves in LEN the length of that same symbol name but
   without either of these suffixes:
     . .{DIGIT}+
     . ${DIGIT}+
     . ___{DIGIT}+
     . __{DIGIT}+.

   These are suffixes introduced by the compiler for entities such as
   nested subprogram for instance, in order to avoid name clashes.
   They do not serve any purpose for the debugger.  */

static void
ada_remove_trailing_digits (const char *encoded, int *len)
{
  if (*len > 1 && isdigit (encoded[*len - 1]))
    {
      int i = *len - 2;

      while (i > 0 && isdigit (encoded[i]))
	i--;
      if (i >= 0 && encoded[i] == '.')
	*len = i;
      else if (i >= 0 && encoded[i] == '$')
	*len = i;
      else if (i >= 2 && startswith (encoded + i - 2, "___"))
	*len = i - 2;
      else if (i >= 1 && startswith (encoded + i - 1, "__"))
	*len = i - 1;
    }
}

/* Remove the suffix introduced by the compiler for protected object
   subprograms.  */

static void
ada_remove_po_subprogram_suffix (const char *encoded, int *len)
{
  /* Remove trailing N.  */

  /* Protected entry subprograms are broken into two
     separate subprograms: The first one is unprotected, and has
     a 'N' suffix; the second is the protected version, and has
     the 'P' suffix.  The second calls the first one after handling
     the protection.  Since the P subprograms are internally generated,
     we leave these names undecoded, giving the user a clue that this
     entity is internal.  */

  if (*len > 1
      && encoded[*len - 1] == 'N'
      && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
    *len = *len - 1;
}

/* If ENCODED ends with a compiler-provided suffix (like ".cold"),
   then update *LEN to remove the suffix and return the offset of the
   character just past the ".".  Otherwise, return -1.  */

static int
remove_compiler_suffix (const char *encoded, int *len)
{
  int offset = *len - 1;
  while (offset > 0 && isalpha (encoded[offset]))
    --offset;
  if (offset > 0 && encoded[offset] == '.')
    {
      *len = offset;
      return offset + 1;
    }
  return -1;
}

/* Convert an ASCII hex string to a number.  Reads exactly N
   characters from STR.  Returns true on success, false if one of the
   digits was not a hex digit.  */
static bool
convert_hex (const char *str, int n, uint32_t *out)
{
  uint32_t result = 0;

  for (int i = 0; i < n; ++i)
    {
      if (!isxdigit (str[i]))
	return false;
      result <<= 4;
      result |= fromhex (str[i]);
    }

  *out = result;
  return true;
}

/* Convert a wide character from its ASCII hex representation in STR
   (consisting of exactly N characters) to the host encoding,
   appending the resulting bytes to OUT.  If N==2 and the Ada source
   charset is not UTF-8, then hex refers to an encoding in the
   ADA_SOURCE_CHARSET; otherwise, use UTF-32.  Return true on success.
   Return false and do not modify OUT on conversion failure.  */
static bool
convert_from_hex_encoded (std::string &out, const char *str, int n)
{
  uint32_t value;

  if (!convert_hex (str, n, &value))
    return false;
  try
    {
      auto_obstack bytes;
      /* In the 'U' case, the hex digits encode the character in the
	 Ada source charset.  However, if the source charset is UTF-8,
	 this really means it is a single-byte UTF-32 character.  */
      if (n == 2 && ada_source_charset != ada_utf8)
	{
	  gdb_byte one_char = (gdb_byte) value;

	  convert_between_encodings (ada_source_charset, host_charset (),
				     &one_char,
				     sizeof (one_char), sizeof (one_char),
				     &bytes, translit_none);
	}
      else
	convert_between_encodings (HOST_UTF32, host_charset (),
				   (const gdb_byte *) &value,
				   sizeof (value), sizeof (value),
				   &bytes, translit_none);
      obstack_1grow (&bytes, '\0');
      out.append ((const char *) obstack_base (&bytes));
    }
  catch (const gdb_exception &)
    {
      /* On failure, the caller will just let the encoded form
	 through, which seems basically reasonable.  */
      return false;
    }

  return true;
}

/* See ada-lang.h.  */

std::string
ada_decode (const char *encoded, bool wrap, bool operators, bool wide)
{
  int i;
  int len0;
  const char *p;
  int at_start_name;
  std::string decoded;
  int suffix = -1;

  /* With function descriptors on PPC64, the value of a symbol named
     ".FN", if it exists, is the entry point of the function "FN".  */
  if (encoded[0] == '.')
    encoded += 1;

  /* The name of the Ada main procedure starts with "_ada_".
     This prefix is not part of the decoded name, so skip this part
     if we see this prefix.  */
  if (startswith (encoded, "_ada_"))
    encoded += 5;
  /* The "___ghost_" prefix is used for ghost entities.  Normally
     these aren't preserved but when they are, it's useful to see
     them.  */
  if (startswith (encoded, "___ghost_"))
    encoded += 9;

  /* If the name starts with '_', then it is not a properly encoded
     name, so do not attempt to decode it.  Similarly, if the name
     starts with '<', the name should not be decoded.  */
  if (encoded[0] == '_' || encoded[0] == '<')
    goto Suppress;

  len0 = strlen (encoded);

  suffix = remove_compiler_suffix (encoded, &len0);

  ada_remove_trailing_digits (encoded, &len0);
  ada_remove_po_subprogram_suffix (encoded, &len0);

  /* Remove the ___X.* suffix if present.  Do not forget to verify that
     the suffix is located before the current "end" of ENCODED.  We want
     to avoid re-matching parts of ENCODED that have previously been
     marked as discarded (by decrementing LEN0).  */
  p = strstr (encoded, "___");
  if (p != NULL && p - encoded < len0 - 3)
    {
      if (p[3] == 'X')
	len0 = p - encoded;
      else
	goto Suppress;
    }

  /* Remove any trailing TKB suffix.  It tells us that this symbol
     is for the body of a task, but that information does not actually
     appear in the decoded name.  */

  if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
    len0 -= 3;

  /* Remove any trailing TB suffix.  The TB suffix is slightly different
     from the TKB suffix because it is used for non-anonymous task
     bodies.  */

  if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
    len0 -= 2;

  /* Remove trailing "B" suffixes.  */
  /* FIXME: brobecker/2006-04-19: Not sure what this are used for...  */

  if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
    len0 -= 1;

  /* Remove trailing __{digit}+ or trailing ${digit}+.  */

  if (len0 > 1 && isdigit (encoded[len0 - 1]))
    {
      i = len0 - 2;
      while ((i >= 0 && isdigit (encoded[i]))
	     || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
	i -= 1;
      if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
	len0 = i - 1;
      else if (i >= 0 && encoded[i] == '$')
	len0 = i;
    }

  /* The first few characters that are not alphabetic are not part
     of any encoding we use, so we can copy them over verbatim.  */

  for (i = 0; i < len0 && !isalpha (encoded[i]); i += 1)
    decoded.push_back (encoded[i]);

  at_start_name = 1;
  while (i < len0)
    {
      /* Is this a symbol function?  */
      if (operators && at_start_name && encoded[i] == 'O')
	{
	  int k;

	  for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
	    {
	      int op_len = strlen (ada_opname_table[k].encoded);
	      if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
			    op_len - 1) == 0)
		  && !isalnum (encoded[i + op_len]))
		{
		  decoded.append (ada_opname_table[k].decoded);
		  at_start_name = 0;
		  i += op_len;
		  break;
		}
	    }
	  if (ada_opname_table[k].encoded != NULL)
	    continue;
	}
      at_start_name = 0;

      /* Replace "TK__" with "__", which will eventually be translated
	 into "." (just below).  */

      if (i < len0 - 4 && startswith (encoded + i, "TK__"))
	i += 2;

      /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
	 be translated into "." (just below).  These are internal names
	 generated for anonymous blocks inside which our symbol is nested.  */

      if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
	  && encoded [i+2] == 'B' && encoded [i+3] == '_'
	  && isdigit (encoded [i+4]))
	{
	  int k = i + 5;
	  
	  while (k < len0 && isdigit (encoded[k]))
	    k++;  /* Skip any extra digit.  */

	  /* Double-check that the "__B_{DIGITS}+" sequence we found
	     is indeed followed by "__".  */
	  if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
	    i = k;
	}

      /* Remove _E{DIGITS}+[sb] */

      /* Just as for protected object subprograms, there are 2 categories
	 of subprograms created by the compiler for each entry.  The first
	 one implements the actual entry code, and has a suffix following
	 the convention above; the second one implements the barrier and
	 uses the same convention as above, except that the 'E' is replaced
	 by a 'B'.

	 Just as above, we do not decode the name of barrier functions
	 to give the user a clue that the code he is debugging has been
	 internally generated.  */

      if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
	  && isdigit (encoded[i+2]))
	{
	  int k = i + 3;

	  while (k < len0 && isdigit (encoded[k]))
	    k++;

	  if (k < len0
	      && (encoded[k] == 'b' || encoded[k] == 's'))
	    {
	      k++;
	      /* Just as an extra precaution, make sure that if this
		 suffix is followed by anything else, it is a '_'.
		 Otherwise, we matched this sequence by accident.  */
	      if (k == len0
		  || (k < len0 && encoded[k] == '_'))
		i = k;
	    }
	}

      /* Remove trailing "N" in [a-z0-9]+N__.  The N is added by
	 the GNAT front-end in protected object subprograms.  */

      if (i < len0 + 3
	  && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
	{
	  /* Backtrack a bit up until we reach either the begining of
	     the encoded name, or "__".  Make sure that we only find
	     digits or lowercase characters.  */
	  const char *ptr = encoded + i - 1;

	  while (ptr >= encoded && is_lower_alphanum (ptr[0]))
	    ptr--;
	  if (ptr < encoded
	      || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
	    i++;
	}

      if (wide && i < len0 + 3 && encoded[i] == 'U' && isxdigit (encoded[i + 1]))
	{
	  if (convert_from_hex_encoded (decoded, &encoded[i + 1], 2))
	    {
	      i += 3;
	      continue;
	    }
	}
      else if (wide && i < len0 + 5 && encoded[i] == 'W' && isxdigit (encoded[i + 1]))
	{
	  if (convert_from_hex_encoded (decoded, &encoded[i + 1], 4))
	    {
	      i += 5;
	      continue;
	    }
	}
      else if (wide && i < len0 + 10 && encoded[i] == 'W' && encoded[i + 1] == 'W'
	       && isxdigit (encoded[i + 2]))
	{
	  if (convert_from_hex_encoded (decoded, &encoded[i + 2], 8))
	    {
	      i += 10;
	      continue;
	    }
	}

      if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
	{
	  /* This is a X[bn]* sequence not separated from the previous
	     part of the name with a non-alpha-numeric character (in other
	     words, immediately following an alpha-numeric character), then
	     verify that it is placed at the end of the encoded name.  If
	     not, then the encoding is not valid and we should abort the
	     decoding.  Otherwise, just skip it, it is used in body-nested
	     package names.  */
	  do
	    i += 1;
	  while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
	  if (i < len0)
	    goto Suppress;
	}
      else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
	{
	 /* Replace '__' by '.'.  */
	  decoded.push_back ('.');
	  at_start_name = 1;
	  i += 2;
	}
      else
	{
	  /* It's a character part of the decoded name, so just copy it
	     over.  */
	  decoded.push_back (encoded[i]);
	  i += 1;
	}
    }

  /* Decoded names should never contain any uppercase character.
     Double-check this, and abort the decoding if we find one.  */

  if (operators)
    {
      for (i = 0; i < decoded.length(); ++i)
	if (isupper (decoded[i]) || decoded[i] == ' ')
	  goto Suppress;
    }

  /* If the compiler added a suffix, append it now.  */
  if (suffix >= 0)
    decoded = decoded + "[" + &encoded[suffix] + "]";

  return decoded;

Suppress:
  if (!wrap)
    return {};

  if (encoded[0] == '<')
    decoded = encoded;
  else
    decoded = '<' + std::string(encoded) + '>';
  return decoded;
}

#ifdef GDB_SELF_TEST

static void
ada_decode_tests ()
{
  /* This isn't valid, but used to cause a crash.  PR gdb/30639.  The
     result does not really matter very much.  */
  SELF_CHECK (ada_decode ("44") == "44");
}

#endif

/* Table for keeping permanent unique copies of decoded names.  Once
   allocated, names in this table are never released.  While this is a
   storage leak, it should not be significant unless there are massive
   changes in the set of decoded names in successive versions of a 
   symbol table loaded during a single session.  */
static struct htab *decoded_names_store;

/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
   in the language-specific part of GSYMBOL, if it has not been
   previously computed.  Tries to save the decoded name in the same
   obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
   in any case, the decoded symbol has a lifetime at least that of
   GSYMBOL).
   The GSYMBOL parameter is "mutable" in the C++ sense: logically
   const, but nevertheless modified to a semantically equivalent form
   when a decoded name is cached in it.  */

const char *
ada_decode_symbol (const struct general_symbol_info *arg)
{
  struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
  const char **resultp =
    &gsymbol->language_specific.demangled_name;

  if (!gsymbol->ada_mangled)
    {
      std::string decoded = ada_decode (gsymbol->linkage_name ());
      struct obstack *obstack = gsymbol->language_specific.obstack;

      gsymbol->ada_mangled = 1;

      if (obstack != NULL)
	*resultp = obstack_strdup (obstack, decoded.c_str ());
      else
	{
	  /* Sometimes, we can't find a corresponding objfile, in
	     which case, we put the result on the heap.  Since we only
	     decode when needed, we hope this usually does not cause a
	     significant memory leak (FIXME).  */

	  char **slot = (char **) htab_find_slot (decoded_names_store,
						  decoded.c_str (), INSERT);

	  if (*slot == NULL)
	    *slot = xstrdup (decoded.c_str ());
	  *resultp = *slot;
	}
    }

  return *resultp;
}



				/* Arrays */

/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
   generated by the GNAT compiler to describe the index type used
   for each dimension of an array, check whether it follows the latest
   known encoding.  If not, fix it up to conform to the latest encoding.
   Otherwise, do nothing.  This function also does nothing if
   INDEX_DESC_TYPE is NULL.

   The GNAT encoding used to describe the array index type evolved a bit.
   Initially, the information would be provided through the name of each
   field of the structure type only, while the type of these fields was
   described as unspecified and irrelevant.  The debugger was then expected
   to perform a global type lookup using the name of that field in order
   to get access to the full index type description.  Because these global
   lookups can be very expensive, the encoding was later enhanced to make
   the global lookup unnecessary by defining the field type as being
   the full index type description.

   The purpose of this routine is to allow us to support older versions
   of the compiler by detecting the use of the older encoding, and by
   fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
   we essentially replace each field's meaningless type by the associated
   index subtype).  */

void
ada_fixup_array_indexes_type (struct type *index_desc_type)
{
  int i;

  if (index_desc_type == NULL)
    return;
  gdb_assert (index_desc_type->num_fields () > 0);

  /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
     to check one field only, no need to check them all).  If not, return
     now.

     If our INDEX_DESC_TYPE was generated using the older encoding,
     the field type should be a meaningless integer type whose name
     is not equal to the field name.  */
  if (index_desc_type->field (0).type ()->name () != NULL
      && strcmp (index_desc_type->field (0).type ()->name (),
		 index_desc_type->field (0).name ()) == 0)
    return;

  /* Fixup each field of INDEX_DESC_TYPE.  */
  for (i = 0; i < index_desc_type->num_fields (); i++)
   {
     const char *name = index_desc_type->field (i).name ();
     struct type *raw_type = ada_check_typedef (ada_find_any_type (name));

     if (raw_type)
       index_desc_type->field (i).set_type (raw_type);
   }
}

/* The desc_* routines return primitive portions of array descriptors
   (fat pointers).  */

/* The descriptor or array type, if any, indicated by TYPE; removes
   level of indirection, if needed.  */

static struct type *
desc_base_type (struct type *type)
{
  if (type == NULL)
    return NULL;
  type = ada_check_typedef (type);
  if (type->code () == TYPE_CODE_TYPEDEF)
    type = ada_typedef_target_type (type);

  if (type != NULL
      && (type->code () == TYPE_CODE_PTR
	  || type->code () == TYPE_CODE_REF))
    return ada_check_typedef (type->target_type ());
  else
    return type;
}

/* True iff TYPE indicates a "thin" array pointer type.  */

static int
is_thin_pntr (struct type *type)
{
  return
    is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
    || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
}

/* The descriptor type for thin pointer type TYPE.  */

static struct type *
thin_descriptor_type (struct type *type)
{
  struct type *base_type = desc_base_type (type);

  if (base_type == NULL)
    return NULL;
  if (is_suffix (ada_type_name (base_type), "___XVE"))
    return base_type;
  else
    {
      struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");

      if (alt_type == NULL)
	return base_type;
      else
	return alt_type;
    }
}

/* A pointer to the array data for thin-pointer value VAL.  */

static struct value *
thin_data_pntr (struct value *val)
{
  struct type *type = ada_check_typedef (val->type ());
  struct type *data_type = desc_data_target_type (thin_descriptor_type (type));

  data_type = lookup_pointer_type (data_type);

  if (type->code () == TYPE_CODE_PTR)
    return value_cast (data_type, val->copy ());
  else
    return value_from_longest (data_type, val->address ());
}

/* True iff TYPE indicates a "thick" array pointer type.  */

static int
is_thick_pntr (struct type *type)
{
  type = desc_base_type (type);
  return (type != NULL && type->code () == TYPE_CODE_STRUCT
	  && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
}

/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
   pointer to one, the type of its bounds data; otherwise, NULL.  */

static struct type *
desc_bounds_type (struct type *type)
{
  struct type *r;

  type = desc_base_type (type);

  if (type == NULL)
    return NULL;
  else if (is_thin_pntr (type))
    {
      type = thin_descriptor_type (type);
      if (type == NULL)
	return NULL;
      r = lookup_struct_elt_type (type, "BOUNDS", 1);
      if (r != NULL)
	return ada_check_typedef (r);
    }
  else if (type->code () == TYPE_CODE_STRUCT)
    {
      r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
      if (r != NULL)
	return ada_check_typedef (ada_check_typedef (r)->target_type ());
    }
  return NULL;
}

/* If ARR is an array descriptor (fat or thin pointer), or pointer to
   one, a pointer to its bounds data.   Otherwise NULL.  */

static struct value *
desc_bounds (struct value *arr)
{
  struct type *type = ada_check_typedef (arr->type ());

  if (is_thin_pntr (type))
    {
      struct type *bounds_type =
	desc_bounds_type (thin_descriptor_type (type));
      LONGEST addr;

      if (bounds_type == NULL)
	error (_("Bad GNAT array descriptor"));

      /* NOTE: The following calculation is not really kosher, but
	 since desc_type is an XVE-encoded type (and shouldn't be),
	 the correct calculation is a real pain.  FIXME (and fix GCC).  */
      if (type->code () == TYPE_CODE_PTR)
	addr = value_as_long (arr);
      else
	addr = arr->address ();

      return
	value_from_longest (lookup_pointer_type (bounds_type),
			    addr - bounds_type->length ());
    }

  else if (is_thick_pntr (type))
    {
      struct value *p_bounds = value_struct_elt (&arr, {}, "P_BOUNDS", NULL,
					       _("Bad GNAT array descriptor"));
      struct type *p_bounds_type = p_bounds->type ();

      if (p_bounds_type
	  && p_bounds_type->code () == TYPE_CODE_PTR)
	{
	  struct type *target_type = p_bounds_type->target_type ();

	  if (target_type->is_stub ())
	    p_bounds = value_cast (lookup_pointer_type
				   (ada_check_typedef (target_type)),
				   p_bounds);
	}
      else
	error (_("Bad GNAT array descriptor"));

      return p_bounds;
    }
  else
    return NULL;
}

/* If TYPE is the type of an array-descriptor (fat pointer),  the bit
   position of the field containing the address of the bounds data.  */

static int
fat_pntr_bounds_bitpos (struct type *type)
{
  return desc_base_type (type)->field (1).loc_bitpos ();
}

/* If TYPE is the type of an array-descriptor (fat pointer), the bit
   size of the field containing the address of the bounds data.  */

static int
fat_pntr_bounds_bitsize (struct type *type)
{
  type = desc_base_type (type);

  if (type->field (1).bitsize () > 0)
    return type->field (1).bitsize ();
  else
    return 8 * ada_check_typedef (type->field (1).type ())->length ();
}

/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
   pointer to one, the type of its array data (a array-with-no-bounds type);
   otherwise, NULL.  Use ada_type_of_array to get an array type with bounds
   data.  */

static struct type *
desc_data_target_type (struct type *type)
{
  type = desc_base_type (type);

  /* NOTE: The following is bogus; see comment in desc_bounds.  */
  if (is_thin_pntr (type))
    return desc_base_type (thin_descriptor_type (type)->field (1).type ());
  else if (is_thick_pntr (type))
    {
      struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);

      if (data_type
	  && ada_check_typedef (data_type)->code () == TYPE_CODE_PTR)
	return ada_check_typedef (data_type->target_type ());
    }

  return NULL;
}

/* If ARR is an array descriptor (fat or thin pointer), a pointer to
   its array data.  */

static struct value *
desc_data (struct value *arr)
{
  struct type *type = arr->type ();

  if (is_thin_pntr (type))
    return thin_data_pntr (arr);
  else if (is_thick_pntr (type))
    return value_struct_elt (&arr, {}, "P_ARRAY", NULL,
			     _("Bad GNAT array descriptor"));
  else
    return NULL;
}


/* If TYPE is the type of an array-descriptor (fat pointer), the bit
   position of the field containing the address of the data.  */

static int
fat_pntr_data_bitpos (struct type *type)
{
  return desc_base_type (type)->field (0).loc_bitpos ();
}

/* If TYPE is the type of an array-descriptor (fat pointer), the bit
   size of the field containing the address of the data.  */

static int
fat_pntr_data_bitsize (struct type *type)
{
  type = desc_base_type (type);

  if (type->field (0).bitsize () > 0)
    return type->field (0).bitsize ();
  else
    return TARGET_CHAR_BIT * type->field (0).type ()->length ();
}

/* If BOUNDS is an array-bounds structure (or pointer to one), return
   the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
   bound, if WHICH is 1.  The first bound is I=1.  */

static struct value *
desc_one_bound (struct value *bounds, int i, int which)
{
  char bound_name[20];
  xsnprintf (bound_name, sizeof (bound_name), "%cB%d",
	     which ? 'U' : 'L', i - 1);
  return value_struct_elt (&bounds, {}, bound_name, NULL,
			   _("Bad GNAT array descriptor bounds"));
}

/* If BOUNDS is an array-bounds structure type, return the bit position
   of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
   bound, if WHICH is 1.  The first bound is I=1.  */

static int
desc_bound_bitpos (struct type *type, int i, int which)
{
  return desc_base_type (type)->field (2 * i + which - 2).loc_bitpos ();
}

/* If BOUNDS is an array-bounds structure type, return the bit field size
   of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
   bound, if WHICH is 1.  The first bound is I=1.  */

static int
desc_bound_bitsize (struct type *type, int i, int which)
{
  type = desc_base_type (type);

  if (type->field (2 * i + which - 2).bitsize () > 0)
    return type->field (2 * i + which - 2).bitsize ();
  else
    return 8 * type->field (2 * i + which - 2).type ()->length ();
}

/* If TYPE is the type of an array-bounds structure, the type of its
   Ith bound (numbering from 1).  Otherwise, NULL.  */

static struct type *
desc_index_type (struct type *type, int i)
{
  type = desc_base_type (type);

  if (type->code () == TYPE_CODE_STRUCT)
    {
      char bound_name[20];
      xsnprintf (bound_name, sizeof (bound_name), "LB%d", i - 1);
      return lookup_struct_elt_type (type, bound_name, 1);
    }
  else
    return NULL;
}

/* The number of index positions in the array-bounds type TYPE.
   Return 0 if TYPE is NULL.  */

static int
desc_arity (struct type *type)
{
  type = desc_base_type (type);

  if (type != NULL)
    return type->num_fields () / 2;
  return 0;
}

/* Non-zero iff TYPE is a simple array type (not a pointer to one) or 
   an array descriptor type (representing an unconstrained array
   type).  */

static int
ada_is_direct_array_type (struct type *type)
{
  if (type == NULL)
    return 0;
  type = ada_check_typedef (type);
  return (type->code () == TYPE_CODE_ARRAY
	  || ada_is_array_descriptor_type (type));
}

/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
 * to one.  */

static int
ada_is_array_type (struct type *type)
{
  while (type != NULL
	 && (type->code () == TYPE_CODE_PTR
	     || type->code () == TYPE_CODE_REF))
    type = type->target_type ();
  return ada_is_direct_array_type (type);
}

/* Non-zero iff TYPE is a simple array type or pointer to one.  */

int
ada_is_simple_array_type (struct type *type)
{
  if (type == NULL)
    return 0;
  type = ada_check_typedef (type);
  return (type->code () == TYPE_CODE_ARRAY
	  || (type->code () == TYPE_CODE_PTR
	      && (ada_check_typedef (type->target_type ())->code ()
		  == TYPE_CODE_ARRAY)));
}

/* Non-zero iff TYPE belongs to a GNAT array descriptor.  */

int
ada_is_array_descriptor_type (struct type *type)
{
  struct type *data_type = desc_data_target_type (type);

  if (type == NULL)
    return 0;
  type = ada_check_typedef (type);
  return (data_type != NULL
	  && data_type->code () == TYPE_CODE_ARRAY
	  && desc_arity (desc_bounds_type (type)) > 0);
}

/* If ARR has a record type in the form of a standard GNAT array descriptor,
   (fat pointer) returns the type of the array data described---specifically,
   a pointer-to-array type.  If BOUNDS is non-zero, the bounds data are filled
   in from the descriptor; otherwise, they are left unspecified.  If
   the ARR denotes a null array descriptor and BOUNDS is non-zero,
   returns NULL.  The result is simply the type of ARR if ARR is not
   a descriptor.  */

static struct type *
ada_type_of_array (struct value *arr, int bounds)
{
  if (ada_is_constrained_packed_array_type (arr->type ()))
    return decode_constrained_packed_array_type (arr->type ());

  if (!ada_is_array_descriptor_type (arr->type ()))
    return arr->type ();

  if (!bounds)
    {
      struct type *array_type =
	ada_check_typedef (desc_data_target_type (arr->type ()));

      if (ada_is_unconstrained_packed_array_type (arr->type ()))
	array_type->field (0).set_bitsize
	  (decode_packed_array_bitsize (arr->type ()));

      return array_type;
    }
  else
    {
      struct type *elt_type;
      int arity;
      struct value *descriptor;

      elt_type = ada_array_element_type (arr->type (), -1);
      arity = ada_array_arity (arr->type ());

      if (elt_type == NULL || arity == 0)
	return ada_check_typedef (arr->type ());

      descriptor = desc_bounds (arr);
      if (value_as_long (descriptor) == 0)
	return NULL;
      while (arity > 0)
	{
	  type_allocator alloc (arr->type ());
	  struct value *low = desc_one_bound (descriptor, arity, 0);
	  struct value *high = desc_one_bound (descriptor, arity, 1);

	  arity -= 1;
	  struct type *range_type
	    = create_static_range_type (alloc, low->type (),
					longest_to_int (value_as_long (low)),
					longest_to_int (value_as_long (high)));
	  elt_type = create_array_type (alloc, elt_type, range_type);
	  INIT_GNAT_SPECIFIC (elt_type);

	  if (ada_is_unconstrained_packed_array_type (arr->type ()))
	    {
	      /* We need to store the element packed bitsize, as well as
		 recompute the array size, because it was previously
		 computed based on the unpacked element size.  */
	      LONGEST lo = value_as_long (low);
	      LONGEST hi = value_as_long (high);

	      elt_type->field (0).set_bitsize
		(decode_packed_array_bitsize (arr->type ()));

	      /* If the array has no element, then the size is already
		 zero, and does not need to be recomputed.  */
	      if (lo < hi)
		{
		  int array_bitsize =
			(hi - lo + 1) * elt_type->field (0).bitsize ();

		  elt_type->set_length ((array_bitsize + 7) / 8);
		}
	    }
	}

      return lookup_pointer_type (elt_type);
    }
}

/* If ARR does not represent an array, returns ARR unchanged.
   Otherwise, returns either a standard GDB array with bounds set
   appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
   GDB array.  Returns NULL if ARR is a null fat pointer.  */

struct value *
ada_coerce_to_simple_array_ptr (struct value *arr)
{
  if (ada_is_array_descriptor_type (arr->type ()))
    {
      struct type *arrType = ada_type_of_array (arr, 1);

      if (arrType == NULL)
	return NULL;
      return value_cast (arrType, desc_data (arr)->copy ());
    }
  else if (ada_is_constrained_packed_array_type (arr->type ()))
    return decode_constrained_packed_array (arr);
  else
    return arr;
}

/* If ARR does not represent an array, returns ARR unchanged.
   Otherwise, returns a standard GDB array describing ARR (which may
   be ARR itself if it already is in the proper form).  */

struct value *
ada_coerce_to_simple_array (struct value *arr)
{
  if (ada_is_array_descriptor_type (arr->type ()))
    {
      struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);

      if (arrVal == NULL)
	error (_("Bounds unavailable for null array pointer."));
      return value_ind (arrVal);
    }
  else if (ada_is_constrained_packed_array_type (arr->type ()))
    return decode_constrained_packed_array (arr);
  else
    return arr;
}

/* If TYPE represents a GNAT array type, return it translated to an
   ordinary GDB array type (possibly with BITSIZE fields indicating
   packing).  For other types, is the identity.  */

struct type *
ada_coerce_to_simple_array_type (struct type *type)
{
  if (ada_is_constrained_packed_array_type (type))
    return decode_constrained_packed_array_type (type);

  if (ada_is_array_descriptor_type (type))
    return ada_check_typedef (desc_data_target_type (type));

  return type;
}

/* Non-zero iff TYPE represents a standard GNAT packed-array type.  */

static int
ada_is_gnat_encoded_packed_array_type  (struct type *type)
{
  if (type == NULL)
    return 0;
  type = desc_base_type (type);
  type = ada_check_typedef (type);
  return
    ada_type_name (type) != NULL
    && strstr (ada_type_name (type), "___XP") != NULL;
}

/* Non-zero iff TYPE represents a standard GNAT constrained
   packed-array type.  */

int
ada_is_constrained_packed_array_type (struct type *type)
{
  return ada_is_gnat_encoded_packed_array_type (type)
    && !ada_is_array_descriptor_type (type);
}

/* Non-zero iff TYPE represents an array descriptor for a
   unconstrained packed-array type.  */

static int
ada_is_unconstrained_packed_array_type (struct type *type)
{
  if (!ada_is_array_descriptor_type (type))
    return 0;

  if (ada_is_gnat_encoded_packed_array_type (type))
    return 1;

  /* If we saw GNAT encodings, then the above code is sufficient.
     However, with minimal encodings, we will just have a thick
     pointer instead.  */
  if (is_thick_pntr (type))
    {
      type = desc_base_type (type);
      /* The structure's first field is a pointer to an array, so this
	 fetches the array type.  */
      type = type->field (0).type ()->target_type ();
      if (type->code () == TYPE_CODE_TYPEDEF)
	type = ada_typedef_target_type (type);
      /* Now we can see if the array elements are packed.  */
      return type->field (0).bitsize () > 0;
    }

  return 0;
}

/* Return true if TYPE is a (Gnat-encoded) constrained packed array
   type, or if it is an ordinary (non-Gnat-encoded) packed array.  */

static bool
ada_is_any_packed_array_type (struct type *type)
{
  return (ada_is_constrained_packed_array_type (type)
	  || (type->code () == TYPE_CODE_ARRAY
	      && type->field (0).bitsize () % 8 != 0));
}

/* Given that TYPE encodes a packed array type (constrained or unconstrained),
   return the size of its elements in bits.  */

static long
decode_packed_array_bitsize (struct type *type)
{
  const char *raw_name;
  const char *tail;
  long bits;

  /* Access to arrays implemented as fat pointers are encoded as a typedef
     of the fat pointer type.  We need the name of the fat pointer type
     to do the decoding, so strip the typedef layer.  */
  if (type->code () == TYPE_CODE_TYPEDEF)
    type = ada_typedef_target_type (type);

  raw_name = ada_type_name (ada_check_typedef (type));
  if (!raw_name)
    raw_name = ada_type_name (desc_base_type (type));

  if (!raw_name)
    return 0;

  tail = strstr (raw_name, "___XP");
  if (tail == nullptr)
    {
      gdb_assert (is_thick_pntr (type));
      /* The structure's first field is a pointer to an array, so this
	 fetches the array type.  */
      type = type->field (0).type ()->target_type ();
      /* Now we can see if the array elements are packed.  */
      return type->field (0).bitsize ();
    }

  if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
    {
      lim_warning
	(_("could not understand bit size information on packed array"));
      return 0;
    }

  return bits;
}

/* Given that TYPE is a standard GDB array type with all bounds filled
   in, and that the element size of its ultimate scalar constituents
   (that is, either its elements, or, if it is an array of arrays, its
   elements' elements, etc.) is *ELT_BITS, return an identical type,
   but with the bit sizes of its elements (and those of any
   constituent arrays) recorded in the BITSIZE components of its
   TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
   in bits.

   Note that, for arrays whose index type has an XA encoding where
   a bound references a record discriminant, getting that discriminant,
   and therefore the actual value of that bound, is not possible
   because none of the given parameters gives us access to the record.
   This function assumes that it is OK in the context where it is being
   used to return an array whose bounds are still dynamic and where
   the length is arbitrary.  */

static struct type *
constrained_packed_array_type (struct type *type, long *elt_bits)
{
  struct type *new_elt_type;
  struct type *new_type;
  struct type *index_type_desc;
  struct type *index_type;
  LONGEST low_bound, high_bound;

  type = ada_check_typedef (type);
  if (type->code () != TYPE_CODE_ARRAY)
    return type;

  index_type_desc = ada_find_parallel_type (type, "___XA");
  if (index_type_desc)
    index_type = to_fixed_range_type (index_type_desc->field (0).type (),
				      NULL);
  else
    index_type = type->index_type ();

  type_allocator alloc (type);
  new_elt_type =
    constrained_packed_array_type (ada_check_typedef (type->target_type ()),
				   elt_bits);
  new_type = create_array_type (alloc, new_elt_type, index_type);
  new_type->field (0).set_bitsize (*elt_bits);
  new_type->set_name (ada_type_name (type));

  if ((check_typedef (index_type)->code () == TYPE_CODE_RANGE
       && is_dynamic_type (check_typedef (index_type)))
      || !get_discrete_bounds (index_type, &low_bound, &high_bound))
    low_bound = high_bound = 0;
  if (high_bound < low_bound)
    {
      *elt_bits = 0;
      new_type->set_length (0);
    }
  else
    {
      *elt_bits *= (high_bound - low_bound + 1);
      new_type->set_length ((*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT);
    }

  new_type->set_is_fixed_instance (true);
  return new_type;
}

/* The array type encoded by TYPE, where
   ada_is_constrained_packed_array_type (TYPE).  */

static struct type *
decode_constrained_packed_array_type (struct type *type)
{
  const char *raw_name = ada_type_name (ada_check_typedef (type));
  char *name;
  const char *tail;
  struct type *shadow_type;
  long bits;

  if (!raw_name)
    raw_name = ada_type_name (desc_base_type (type));

  if (!raw_name)
    return NULL;

  name = (char *) alloca (strlen (raw_name) + 1);
  tail = strstr (raw_name, "___XP");
  type = desc_base_type (type);

  memcpy (name, raw_name, tail - raw_name);
  name[tail - raw_name] = '\000';

  shadow_type = ada_find_parallel_type_with_name (type, name);

  if (shadow_type == NULL)
    {
      lim_warning (_("could not find bounds information on packed array"));
      return NULL;
    }
  shadow_type = check_typedef (shadow_type);

  if (shadow_type->code () != TYPE_CODE_ARRAY)
    {
      lim_warning (_("could not understand bounds "
		     "information on packed array"));
      return NULL;
    }

  bits = decode_packed_array_bitsize (type);
  return constrained_packed_array_type (shadow_type, &bits);
}

/* Helper function for decode_constrained_packed_array.  Set the field
   bitsize on a series of packed arrays.  Returns the number of
   elements in TYPE.  */

static LONGEST
recursively_update_array_bitsize (struct type *type)
{
  gdb_assert (type->code () == TYPE_CODE_ARRAY);

  LONGEST low, high;
  if (!get_discrete_bounds (type->index_type (), &low, &high)
      || low > high)
    return 0;
  LONGEST our_len = high - low + 1;

  struct type *elt_type = type->target_type ();
  if (elt_type->code () == TYPE_CODE_ARRAY)
    {
      LONGEST elt_len = recursively_update_array_bitsize (elt_type);
      LONGEST elt_bitsize = elt_len * elt_type->field (0).bitsize ();
      type->field (0).set_bitsize (elt_bitsize);

      type->set_length (((our_len * elt_bitsize + HOST_CHAR_BIT - 1)
			 / HOST_CHAR_BIT));
    }

  return our_len;
}

/* Given that ARR is a struct value *indicating a GNAT constrained packed
   array, returns a simple array that denotes that array.  Its type is a
   standard GDB array type except that the BITSIZEs of the array
   target types are set to the number of bits in each element, and the
   type length is set appropriately.  */

static struct value *
decode_constrained_packed_array (struct value *arr)
{
  struct type *type;

  /* If our value is a pointer, then dereference it. Likewise if
     the value is a reference.  Make sure that this operation does not
     cause the target type to be fixed, as this would indirectly cause
     this array to be decoded.  The rest of the routine assumes that
     the array hasn't been decoded yet, so we use the basic "coerce_ref"
     and "value_ind" routines to perform the dereferencing, as opposed
     to using "ada_coerce_ref" or "ada_value_ind".  */
  arr = coerce_ref (arr);
  if (ada_check_typedef (arr->type ())->code () == TYPE_CODE_PTR)
    arr = value_ind (arr);

  type = decode_constrained_packed_array_type (arr->type ());
  if (type == NULL)
    {
      error (_("can't unpack array"));
      return NULL;
    }

  /* Decoding the packed array type could not correctly set the field
     bitsizes for any dimension except the innermost, because the
     bounds may be variable and were not passed to that function.  So,
     we further resolve the array bounds here and then update the
     sizes.  */
  const gdb_byte *valaddr = arr->contents_for_printing ().data ();
  CORE_ADDR address = arr->address ();
  gdb::array_view<const gdb_byte> view
    = gdb::make_array_view (valaddr, type->length ());
  type = resolve_dynamic_type (type, view, address);
  recursively_update_array_bitsize (type);

  if (type_byte_order (arr->type ()) == BFD_ENDIAN_BIG
      && ada_is_modular_type (arr->type ()))
    {
       /* This is a (right-justified) modular type representing a packed
	  array with no wrapper.  In order to interpret the value through
	  the (left-justified) packed array type we just built, we must
	  first left-justify it.  */
      int bit_size, bit_pos;
      ULONGEST mod;

      mod = ada_modulus (arr->type ()) - 1;
      bit_size = 0;
      while (mod > 0)
	{
	  bit_size += 1;
	  mod >>= 1;
	}
      bit_pos = HOST_CHAR_BIT * arr->type ()->length () - bit_size;
      arr = ada_value_primitive_packed_val (arr, NULL,
					    bit_pos / HOST_CHAR_BIT,
					    bit_pos % HOST_CHAR_BIT,
					    bit_size,
					    type);
    }

  return coerce_unspec_val_to_type (arr, type);
}


/* The value of the element of packed array ARR at the ARITY indices
   given in IND.   ARR must be a simple array.  */

static struct value *
value_subscript_packed (struct value *arr, int arity, struct value **ind)
{
  int i;
  int bits, elt_off, bit_off;
  long elt_total_bit_offset;
  struct type *elt_type;
  struct value *v;

  bits = 0;
  elt_total_bit_offset = 0;
  elt_type = ada_check_typedef (arr->type ());
  for (i = 0; i < arity; i += 1)
    {
      if (elt_type->code () != TYPE_CODE_ARRAY
	  || elt_type->field (0).bitsize () == 0)
	error
	  (_("attempt to do packed indexing of "
	     "something other than a packed array"));
      else
	{
	  struct type *range_type = elt_type->index_type ();
	  LONGEST lowerbound, upperbound;
	  LONGEST idx;

	  if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
	    {
	      lim_warning (_("don't know bounds of array"));
	      lowerbound = upperbound = 0;
	    }

	  idx = pos_atr (ind[i]);
	  if (idx < lowerbound || idx > upperbound)
	    lim_warning (_("packed array index %ld out of bounds"),
			 (long) idx);
	  bits = elt_type->field (0).bitsize ();
	  elt_total_bit_offset += (idx - lowerbound) * bits;
	  elt_type = ada_check_typedef (elt_type->target_type ());
	}
    }
  elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
  bit_off = elt_total_bit_offset % HOST_CHAR_BIT;

  v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
				      bits, elt_type);
  return v;
}

/* Non-zero iff TYPE includes negative integer values.  */

static int
has_negatives (struct type *type)
{
  switch (type->code ())
    {
    default:
      return 0;
    case TYPE_CODE_INT:
      return !type->is_unsigned ();
    case TYPE_CODE_RANGE:
      return type->bounds ()->low.const_val () - type->bounds ()->bias < 0;
    }
}

/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
   unpack that data into UNPACKED.  UNPACKED_LEN is the size in bytes of
   the unpacked buffer.

   The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
   enough to contain at least BIT_OFFSET bits.  If not, an error is raised.

   IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
   zero otherwise.

   IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.

   IS_SCALAR is nonzero if the data corresponds to a signed type.  */

static void
ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
			  gdb_byte *unpacked, int unpacked_len,
			  int is_big_endian, int is_signed_type,
			  int is_scalar)
{
  int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
  int src_idx;                  /* Index into the source area */
  int src_bytes_left;           /* Number of source bytes left to process.  */
  int srcBitsLeft;              /* Number of source bits left to move */
  int unusedLS;                 /* Number of bits in next significant
				   byte of source that are unused */

  int unpacked_idx;             /* Index into the unpacked buffer */
  int unpacked_bytes_left;      /* Number of bytes left to set in unpacked.  */

  unsigned long accum;          /* Staging area for bits being transferred */
  int accumSize;                /* Number of meaningful bits in accum */
  unsigned char sign;

  /* Transmit bytes from least to most significant; delta is the direction
     the indices move.  */
  int delta = is_big_endian ? -1 : 1;

  /* Make sure that unpacked is large enough to receive the BIT_SIZE
     bits from SRC.  .*/
  if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
    error (_("Cannot unpack %d bits into buffer of %d bytes"),
	   bit_size, unpacked_len);

  srcBitsLeft = bit_size;
  src_bytes_left = src_len;
  unpacked_bytes_left = unpacked_len;
  sign = 0;

  if (is_big_endian)
    {
      src_idx = src_len - 1;
      if (is_signed_type
	  && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
	sign = ~0;

      unusedLS =
	(HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
	% HOST_CHAR_BIT;

      if (is_scalar)
	{
	  accumSize = 0;
	  unpacked_idx = unpacked_len - 1;
	}
      else
	{
	  /* Non-scalar values must be aligned at a byte boundary...  */
	  accumSize =
	    (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
	  /* ... And are placed at the beginning (most-significant) bytes
	     of the target.  */
	  unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
	  unpacked_bytes_left = unpacked_idx + 1;
	}
    }
  else
    {
      int sign_bit_offset = (bit_size + bit_offset - 1) % 8;

      src_idx = unpacked_idx = 0;
      unusedLS = bit_offset;
      accumSize = 0;

      if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
	sign = ~0;
    }

  accum = 0;
  while (src_bytes_left > 0)
    {
      /* Mask for removing bits of the next source byte that are not
	 part of the value.  */
      unsigned int unusedMSMask =
	(1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
	1;
      /* Sign-extend bits for this byte.  */
      unsigned int signMask = sign & ~unusedMSMask;

      accum |=
	(((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
      accumSize += HOST_CHAR_BIT - unusedLS;
      if (accumSize >= HOST_CHAR_BIT)
	{
	  unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
	  accumSize -= HOST_CHAR_BIT;
	  accum >>= HOST_CHAR_BIT;
	  unpacked_bytes_left -= 1;
	  unpacked_idx += delta;
	}
      srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
      unusedLS = 0;
      src_bytes_left -= 1;
      src_idx += delta;
    }
  while (unpacked_bytes_left > 0)
    {
      accum |= sign << accumSize;
      unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
      accumSize -= HOST_CHAR_BIT;
      if (accumSize < 0)
	accumSize = 0;
      accum >>= HOST_CHAR_BIT;
      unpacked_bytes_left -= 1;
      unpacked_idx += delta;
    }
}

/* Create a new value of type TYPE from the contents of OBJ starting
   at byte OFFSET, and bit offset BIT_OFFSET within that byte,
   proceeding for BIT_SIZE bits.  If OBJ is an lval in memory, then
   assigning through the result will set the field fetched from.
   VALADDR is ignored unless OBJ is NULL, in which case,
   VALADDR+OFFSET must address the start of storage containing the 
   packed value.  The value returned  in this case is never an lval.
   Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT.  */

struct value *
ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
				long offset, int bit_offset, int bit_size,
				struct type *type)
{
  struct value *v;
  const gdb_byte *src;                /* First byte containing data to unpack */
  gdb_byte *unpacked;
  const int is_scalar = is_scalar_type (type);
  const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
  gdb::byte_vector staging;

  type = ada_check_typedef (type);

  if (obj == NULL)
    src = valaddr + offset;
  else
    src = obj->contents ().data () + offset;

  if (is_dynamic_type (type))
    {
      /* The length of TYPE might by dynamic, so we need to resolve
	 TYPE in order to know its actual size, which we then use
	 to create the contents buffer of the value we return.
	 The difficulty is that the data containing our object is
	 packed, and therefore maybe not at a byte boundary.  So, what
	 we do, is unpack the data into a byte-aligned buffer, and then
	 use that buffer as our object's value for resolving the type.  */
      int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
      staging.resize (staging_len);

      ada_unpack_from_contents (src, bit_offset, bit_size,
				staging.data (), staging.size (),
				is_big_endian, has_negatives (type),
				is_scalar);
      type = resolve_dynamic_type (type, staging, 0);
      if (type->length () < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
	{
	  /* This happens when the length of the object is dynamic,
	     and is actually smaller than the space reserved for it.
	     For instance, in an array of variant records, the bit_size
	     we're given is the array stride, which is constant and
	     normally equal to the maximum size of its element.
	     But, in reality, each element only actually spans a portion
	     of that stride.  */
	  bit_size = type->length () * HOST_CHAR_BIT;
	}
    }

  if (obj == NULL)
    {
      v = value::allocate (type);
      src = valaddr + offset;
    }
  else if (obj->lval () == lval_memory && obj->lazy ())
    {
      int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
      gdb_byte *buf;

      v = value_at (type, obj->address () + offset);
      buf = (gdb_byte *) alloca (src_len);
      read_memory (v->address (), buf, src_len);
      src = buf;
    }
  else
    {
      v = value::allocate (type);
      src = obj->contents ().data () + offset;
    }

  if (obj != NULL)
    {
      long new_offset = offset;

      v->set_component_location (obj);
      v->set_bitpos (bit_offset + obj->bitpos ());
      v->set_bitsize (bit_size);
      if (v->bitpos () >= HOST_CHAR_BIT)
	{
	  ++new_offset;
	  v->set_bitpos (v->bitpos () - HOST_CHAR_BIT);
	}
      v->set_offset (new_offset);

      /* Also set the parent value.  This is needed when trying to
	 assign a new value (in inferior memory).  */
      v->set_parent (obj);
    }
  else
    v->set_bitsize (bit_size);
  unpacked = v->contents_writeable ().data ();

  if (bit_size == 0)
    {
      memset (unpacked, 0, type->length ());
      return v;
    }

  if (staging.size () == type->length ())
    {
      /* Small short-cut: If we've unpacked the data into a buffer
	 of the same size as TYPE's length, then we can reuse that,
	 instead of doing the unpacking again.  */
      memcpy (unpacked, staging.data (), staging.size ());
    }
  else
    ada_unpack_from_contents (src, bit_offset, bit_size,
			      unpacked, type->length (),
			      is_big_endian, has_negatives (type), is_scalar);

  return v;
}

/* Store the contents of FROMVAL into the location of TOVAL.
   Return a new value with the location of TOVAL and contents of
   FROMVAL.   Handles assignment into packed fields that have
   floating-point or non-scalar types.  */

static struct value *
ada_value_assign (struct value *toval, struct value *fromval)
{
  struct type *type = toval->type ();
  int bits = toval->bitsize ();

  toval = ada_coerce_ref (toval);
  fromval = ada_coerce_ref (fromval);

  if (ada_is_direct_array_type (toval->type ()))
    toval = ada_coerce_to_simple_array (toval);
  if (ada_is_direct_array_type (fromval->type ()))
    fromval = ada_coerce_to_simple_array (fromval);

  if (!toval->deprecated_modifiable ())
    error (_("Left operand of assignment is not a modifiable lvalue."));

  if (toval->lval () == lval_memory
      && bits > 0
      && (type->code () == TYPE_CODE_FLT
	  || type->code () == TYPE_CODE_STRUCT))
    {
      int len = (toval->bitpos ()
		 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
      int from_size;
      gdb_byte *buffer = (gdb_byte *) alloca (len);
      struct value *val;
      CORE_ADDR to_addr = toval->address ();

      if (type->code () == TYPE_CODE_FLT)
	fromval = value_cast (type, fromval);

      read_memory (to_addr, buffer, len);
      from_size = fromval->bitsize ();
      if (from_size == 0)
	from_size = fromval->type ()->length () * TARGET_CHAR_BIT;

      const int is_big_endian = type_byte_order (type) == BFD_ENDIAN_BIG;
      ULONGEST from_offset = 0;
      if (is_big_endian && is_scalar_type (fromval->type ()))
	from_offset = from_size - bits;
      copy_bitwise (buffer, toval->bitpos (),
		    fromval->contents ().data (), from_offset,
		    bits, is_big_endian);
      write_memory_with_notification (to_addr, buffer, len);

      val = toval->copy ();
      memcpy (val->contents_raw ().data (),
	      fromval->contents ().data (),
	      type->length ());
      val->deprecated_set_type (type);

      return val;
    }

  return value_assign (toval, fromval);
}


/* Given that COMPONENT is a memory lvalue that is part of the lvalue
   CONTAINER, assign the contents of VAL to COMPONENTS's place in
   CONTAINER.  Modifies the VALUE_CONTENTS of CONTAINER only, not
   COMPONENT, and not the inferior's memory.  The current contents
   of COMPONENT are ignored.

   Although not part of the initial design, this function also works
   when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
   had a null address, and COMPONENT had an address which is equal to
   its offset inside CONTAINER.  */

static void
value_assign_to_component (struct value *container, struct value *component,
			   struct value *val)
{
  LONGEST offset_in_container =
    (LONGEST)  (component->address () - container->address ());
  int bit_offset_in_container =
    component->bitpos () - container->bitpos ();
  int bits;

  val = value_cast (component->type (), val);

  if (component->bitsize () == 0)
    bits = TARGET_CHAR_BIT * component->type ()->length ();
  else
    bits = component->bitsize ();

  if (type_byte_order (container->type ()) == BFD_ENDIAN_BIG)
    {
      int src_offset;

      if (is_scalar_type (check_typedef (component->type ())))
	src_offset
	  = component->type ()->length () * TARGET_CHAR_BIT - bits;
      else
	src_offset = 0;
      copy_bitwise ((container->contents_writeable ().data ()
		     + offset_in_container),
		    container->bitpos () + bit_offset_in_container,
		    val->contents ().data (), src_offset, bits, 1);
    }
  else
    copy_bitwise ((container->contents_writeable ().data ()
		   + offset_in_container),
		  container->bitpos () + bit_offset_in_container,
		  val->contents ().data (), 0, bits, 0);
}

/* Determine if TYPE is an access to an unconstrained array.  */

bool
ada_is_access_to_unconstrained_array (struct type *type)
{
  return (type->code () == TYPE_CODE_TYPEDEF
	  && is_thick_pntr (ada_typedef_target_type (type)));
}

/* The value of the element of array ARR at the ARITY indices given in IND.
   ARR may be either a simple array, GNAT array descriptor, or pointer
   thereto.  */

struct value *
ada_value_subscript (struct value *arr, int arity, struct value **ind)
{
  int k;
  struct value *elt;
  struct type *elt_type;

  elt = ada_coerce_to_simple_array (arr);

  elt_type = ada_check_typedef (elt->type ());
  if (elt_type->code () == TYPE_CODE_ARRAY
      && elt_type->field (0).bitsize () > 0)
    return value_subscript_packed (elt, arity, ind);

  for (k = 0; k < arity; k += 1)
    {
      struct type *saved_elt_type = elt_type->target_type ();

      if (elt_type->code () != TYPE_CODE_ARRAY)
	error (_("too many subscripts (%d expected)"), k);

      elt = value_subscript (elt, pos_atr (ind[k]));

      if (ada_is_access_to_unconstrained_array (saved_elt_type)
	  && elt->type ()->code () != TYPE_CODE_TYPEDEF)
	{
	  /* The element is a typedef to an unconstrained array,
	     except that the value_subscript call stripped the
	     typedef layer.  The typedef layer is GNAT's way to
	     specify that the element is, at the source level, an
	     access to the unconstrained array, rather than the
	     unconstrained array.  So, we need to restore that
	     typedef layer, which we can do by forcing the element's
	     type back to its original type. Otherwise, the returned
	     value is going to be printed as the array, rather
	     than as an access.  Another symptom of the same issue
	     would be that an expression trying to dereference the
	     element would also be improperly rejected.  */
	  elt->deprecated_set_type (saved_elt_type);
	}

      elt_type = ada_check_typedef (elt->type ());
    }

  return elt;
}

/* Assuming ARR is a pointer to a GDB array, the value of the element
   of *ARR at the ARITY indices given in IND.
   Does not read the entire array into memory.

   Note: Unlike what one would expect, this function is used instead of
   ada_value_subscript for basically all non-packed array types.  The reason
   for this is that a side effect of doing our own pointer arithmetics instead
   of relying on value_subscript is that there is no implicit typedef peeling.
   This is important for arrays of array accesses, where it allows us to
   preserve the fact that the array's element is an array access, where the
   access part os encoded in a typedef layer.  */

static struct value *
ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
{
  int k;
  struct value *array_ind = ada_value_ind (arr);
  struct type *type
    = check_typedef (array_ind->enclosing_type ());

  if (type->code () == TYPE_CODE_ARRAY
      && type->field (0).bitsize () > 0)
    return value_subscript_packed (array_ind, arity, ind);

  for (k = 0; k < arity; k += 1)
    {
      LONGEST lwb, upb;

      if (type->code () != TYPE_CODE_ARRAY)
	error (_("too many subscripts (%d expected)"), k);
      arr = value_cast (lookup_pointer_type (type->target_type ()),
			arr->copy ());
      get_discrete_bounds (type->index_type (), &lwb, &upb);
      arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
      type = type->target_type ();
    }

  return value_ind (arr);
}

/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
   actual type of ARRAY_PTR is ignored), returns the Ada slice of
   HIGH'Pos-LOW'Pos+1 elements starting at index LOW.  The lower bound of
   this array is LOW, as per Ada rules.  */
static struct value *
ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
			  int low, int high)
{
  struct type *type0 = ada_check_typedef (type);
  struct type *base_index_type = type0->index_type ()->target_type ();
  type_allocator alloc (base_index_type);
  struct type *index_type
    = create_static_range_type (alloc, base_index_type, low, high);
  struct type *slice_type = create_array_type_with_stride
			      (alloc, type0->target_type (), index_type,
			       type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
			       type0->field (0).bitsize ());
  int base_low =  ada_discrete_type_low_bound (type0->index_type ());
  std::optional<LONGEST> base_low_pos, low_pos;
  CORE_ADDR base;

  low_pos = discrete_position (base_index_type, low);
  base_low_pos = discrete_position (base_index_type, base_low);

  if (!low_pos.has_value () || !base_low_pos.has_value ())
    {
      warning (_("unable to get positions in slice, use bounds instead"));
      low_pos = low;
      base_low_pos = base_low;
    }

  ULONGEST stride = slice_type->field (0).bitsize () / 8;
  if (stride == 0)
    stride = type0->target_type ()->length ();

  base = value_as_address (array_ptr) + (*low_pos - *base_low_pos) * stride;
  return value_at_lazy (slice_type, base);
}


static struct value *
ada_value_slice (struct value *array, int low, int high)
{
  struct type *type = ada_check_typedef (array->type ());
  struct type *base_index_type = type->index_type ()->target_type ();
  type_allocator alloc (type->index_type ());
  struct type *index_type
    = create_static_range_type (alloc, type->index_type (), low, high);
  struct type *slice_type = create_array_type_with_stride
			      (alloc, type->target_type (), index_type,
			       type->dyn_prop (DYN_PROP_BYTE_STRIDE),
			       type->field (0).bitsize ());
  std::optional<LONGEST> low_pos, high_pos;


  low_pos = discrete_position (base_index_type, low);
  high_pos = discrete_position (base_index_type, high);

  if (!low_pos.has_value () || !high_pos.has_value ())
    {
      warning (_("unable to get positions in slice, use bounds instead"));
      low_pos = low;
      high_pos = high;
    }

  return value_cast (slice_type,
		     value_slice (array, low, *high_pos - *low_pos + 1));
}

/* If type is a record type in the form of a standard GNAT array
   descriptor, returns the number of dimensions for type.  If arr is a
   simple array, returns the number of "array of"s that prefix its
   type designation.  Otherwise, returns 0.  */

int
ada_array_arity (struct type *type)
{
  int arity;