Google Git
Sign in
gnu / binutils-gdb / 2786ef85faf16c13029548832c4e4b025bf2624c / . / gdb / ada-lang.c
blob: 98718bcc98bf2f434c66240fa6854296b4fd4c84 [file] [log] [blame]
/* Ada language support routines for GDB, the GNU debugger.
Copyright (C) 1992-2021 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 "defs.h"
#include <ctype.h>
#include "gdb_regex.h"
#include "frame.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "gdbcmd.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 "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 <algorithm>
#include "ada-exp.h"
/* Define whether or not the C operator '/' truncates towards zero for
differently signed operands (truncation direction is undefined in C).
Copied from valarith.c. */
#ifndef TRUNCATION_TOWARDS_ZERO
#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
#endif
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_enum, struct objfile *);
static void ada_add_all_symbols (std::vector<struct block_symbol> &,
const struct block *,
const lookup_name_info &lookup_name,
domain_enum, 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 symbol *standard_lookup (const char *, const struct block *,
domain_enum);
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 void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
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);
/* The result of a symbol lookup to be stored in our symbol cache. */
struct cache_entry
{
/* The name used to perform the lookup. */
const char *name;
/* The namespace used during the lookup. */
domain_enum domain;
/* The symbol returned by the lookup, or NULL if no matching symbol
was found. */
struct symbol *sym;
/* The block where the symbol was found, or NULL if no matching
symbol was found. */
const struct block *block;
/* A pointer to the next entry with the same hash. */
struct cache_entry *next;
};
/* The Ada symbol cache, used to store the result of Ada-mode symbol
lookups in the course of executing the user's commands.
The cache is implemented using a simple, fixed-sized hash.
The size is fixed on the grounds that there are not likely to be
all that many symbols looked up during any given session, regardless
of the size of the symbol table. If we decide to go to a resizable
table, let's just use the stuff from libiberty instead. */
#define HASH_SIZE 1009
struct ada_symbol_cache
{
/* An obstack used to store the entries in our cache. */
struct auto_obstack cache_space;
/* The root of the hash table used to implement our symbol cache. */
struct cache_entry *root[HASH_SIZE] {};
};
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 struct 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. */
/* This module's per-program-space data. */
struct ada_pspace_data
{
/* The Ada symbol cache. */
std::unique_ptr<ada_symbol_cache> sym_cache;
};
/* Key to our per-program-space data. */
static const struct program_space_key<ada_pspace_data> 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 struct ada_pspace_data *
get_ada_pspace_data (struct program_space *pspace)
{
struct ada_pspace_data *data;
data = ada_pspace_data_handle.get (pspace);
if (data == NULL)
data = ada_pspace_data_handle.emplace (pspace);
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 (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 (value_type (val) == type)
return val;
else
{
struct value *result;
if (value_optimized_out (val))
result = allocate_optimized_out_value (type);
else if (value_lazy (val)
/* Be careful not to make a lazy not_lval value. */
|| (VALUE_LVAL (val) != not_lval
&& TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))))
result = allocate_value_lazy (type);
else
{
result = allocate_value (type);
value_contents_copy (result, 0, val, 0, TYPE_LENGTH (type));
}
set_value_component_location (result, val);
set_value_bitsize (result, value_bitsize (val));
set_value_bitpos (result, value_bitpos (val));
if (VALUE_LVAL (result) == lval_memory)
set_value_address (result, value_address (val));
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 (TYPE_LENGTH (t));
else
return max_of_size (TYPE_LENGTH (t));
}
/* 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 (TYPE_LENGTH (t));
}
/* 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.kind () == PROP_CONST)
return high.const_val ();
else
{
gdb_assert (high.kind () == PROP_UNDEFINED);
/* 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_ENUMVAL (type, type->num_fields () - 1);
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.kind () == PROP_CONST)
return low.const_val ();
else
{
gdb_assert (low.kind () == PROP_UNDEFINED);
/* 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_ENUMVAL (type, 0);
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) || TYPE_TARGET_TYPE (type) == NULL)
return type;
type = TYPE_TARGET_TYPE (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 (value));
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 program is in Ada, return language_ada, otherwise return LANG
(the main program is in Ada iif the adainit symbol is found). */
static enum language
ada_update_initial_language (enum language lang)
{
if (lookup_minimal_symbol ("adainit", NULL, NULL).minsym != NULL)
return language_ada;
return lang;
}
/* 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. */
char *
ada_main_name (void)
{
struct bound_minimal_symbol msym;
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. */
msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
if (msym.minsym != NULL)
{
CORE_ADDR main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
if (main_program_name_addr == 0)
error (_("Invalid address for Ada main program name."));
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');
}
/* 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;
for (const char *p = decoded; *p != '\0'; p += 1)
{
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);
}
return encoding_buffer;
}
/* The "encoded" form of DECODED, according to GNAT conventions. */
std::string
ada_encode (const char *decoded)
{
return ada_encode_1 (decoded, true);
}
/* Return NAME folded to lower case, or, if surrounded by single
quotes, unfolded, but with the quotes stripped away. Result good
to next call. */
static const char *
ada_fold_name (gdb::string_view name)
{
static std::string fold_storage;
if (!name.empty () && name[0] == '\'')
fold_storage = gdb::to_string (name.substr (1, name.size () - 2));
else
{
fold_storage = gdb::to_string (name);
for (int i = 0; i < name.size (); i += 1)
fold_storage[i] = tolower (fold_storage[i]);
}
return fold_storage.c_str ();
}
/* 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;
}
/* See ada-lang.h. */
std::string
ada_decode (const char *encoded, bool wrap)
{
int i, j;
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;
/* 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;
/* Make decoded big enough for possible expansion by operator name. */
decoded.resize (2 * len0 + 1, 'X');
/* 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 (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, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
decoded[j] = encoded[i];
at_start_name = 1;
while (i < len0)
{
/* Is this a symbol function? */
if (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]))
{
strcpy (&decoded.front() + j, ada_opname_table[k].decoded);
at_start_name = 0;
i += op_len;
j += strlen (ada_opname_table[k].decoded);
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 (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[j] = '.';
at_start_name = 1;
i += 2;
j += 1;
}
else
{
/* It's a character part of the decoded name, so just copy it
over. */
decoded[j] = encoded[i];
i += 1;
j += 1;
}
}
decoded.resize (j);
/* Decoded names should never contain any uppercase character.
Double-check this, and abort the decoding if we find one. */
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;
}
/* 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 (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 (value_type (val));
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, value_copy (val));
else
return value_from_longest (data_type, value_address (val));
}
/* 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 (TYPE_TARGET_TYPE (ada_check_typedef (r)));
}
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 (value_type (arr));
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 = value_address (arr);
return
value_from_longest (lookup_pointer_type (bounds_type),
addr - TYPE_LENGTH (bounds_type));
}
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 = value_type (p_bounds);
if (p_bounds_type
&& p_bounds_type->code () == TYPE_CODE_PTR)
{
struct type *target_type = TYPE_TARGET_TYPE (p_bounds_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 TYPE_FIELD_BITPOS (desc_base_type (type), 1);
}
/* 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_BITSIZE (type, 1) > 0)
return TYPE_FIELD_BITSIZE (type, 1);
else
return 8 * TYPE_LENGTH (ada_check_typedef (type->field (1).type ()));
}
/* 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 (TYPE_TARGET_TYPE (data_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 = value_type (arr);
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 TYPE_FIELD_BITPOS (desc_base_type (type), 0);
}
/* 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_BITSIZE (type, 0) > 0)
return TYPE_FIELD_BITSIZE (type, 0);
else
return TARGET_CHAR_BIT * TYPE_LENGTH (type->field (0).type ());
}
/* 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 TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
}
/* 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_BITSIZE (type, 2 * i + which - 2) > 0)
return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
else
return 8 * TYPE_LENGTH (type->field (2 * i + which - 2).type ());
}
/* 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 (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 (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);
}
/* Non-zero iff type is a partially mal-formed GNAT array
descriptor. FIXME: This is to compensate for some problems with
debugging output from GNAT. Re-examine periodically to see if it
is still needed. */
int
ada_is_bogus_array_descriptor (struct type *type)
{
return
type != NULL
&& type->code () == TYPE_CODE_STRUCT
&& (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
|| lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
&& !ada_is_array_descriptor_type (type);
}
/* 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 (value_type (arr)))
return decode_constrained_packed_array_type (value_type (arr));
if (!ada_is_array_descriptor_type (value_type (arr)))
return value_type (arr);
if (!bounds)
{
struct type *array_type =
ada_check_typedef (desc_data_target_type (value_type (arr)));
if (ada_is_unconstrained_packed_array_type (value_type (arr)))
TYPE_FIELD_BITSIZE (array_type, 0) =
decode_packed_array_bitsize (value_type (arr));
return array_type;
}
else
{
struct type *elt_type;
int arity;
struct value *descriptor;
elt_type = ada_array_element_type (value_type (arr), -1);
arity = ada_array_arity (value_type (arr));
if (elt_type == NULL || arity == 0)
return ada_check_typedef (value_type (arr));
descriptor = desc_bounds (arr);
if (value_as_long (descriptor) == 0)
return NULL;
while (arity > 0)
{
struct type *range_type = alloc_type_copy (value_type (arr));
struct type *array_type = alloc_type_copy (value_type (arr));
struct value *low = desc_one_bound (descriptor, arity, 0);
struct value *high = desc_one_bound (descriptor, arity, 1);
arity -= 1;
create_static_range_type (range_type, value_type (low),
longest_to_int (value_as_long (low)),
longest_to_int (value_as_long (high)));
elt_type = create_array_type (array_type, elt_type, range_type);
if (ada_is_unconstrained_packed_array_type (value_type (arr)))
{
/* 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);
TYPE_FIELD_BITSIZE (elt_type, 0) =
decode_packed_array_bitsize (value_type (arr));
/* 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) * TYPE_FIELD_BITSIZE (elt_type, 0);
TYPE_LENGTH (array_type) = (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 (value_type (arr)))
{
struct type *arrType = ada_type_of_array (arr, 1);
if (arrType == NULL)
return NULL;
return value_cast (arrType, value_copy (desc_data (arr)));
}
else if (ada_is_constrained_packed_array_type (value_type (arr)))
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 (value_type (arr)))
{
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 (value_type (arr)))
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_TARGET_TYPE (type->field (0).type ());
/* Now we can see if the array elements are packed. */
return TYPE_FIELD_BITSIZE (type, 0) > 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_BITSIZE (type, 0) % 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_TARGET_TYPE (type->field (0).type ());
/* Now we can see if the array elements are packed. */
return TYPE_FIELD_BITSIZE (type, 0);
}
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 ();
new_type = alloc_type_copy (type);
new_elt_type =
constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
elt_bits);
create_array_type (new_type, new_elt_type, index_type);
TYPE_FIELD_BITSIZE (new_type, 0) = *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 = TYPE_LENGTH (new_type) = 0;
else
{
*elt_bits *= (high_bound - low_bound + 1);
TYPE_LENGTH (new_type) =
(*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 (type);
if (elt_type->code () == TYPE_CODE_ARRAY)
{
LONGEST elt_len = recursively_update_array_bitsize (elt_type);
LONGEST elt_bitsize = elt_len * TYPE_FIELD_BITSIZE (elt_type, 0);
TYPE_FIELD_BITSIZE (type, 0) = elt_bitsize;
TYPE_LENGTH (type) = ((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 (value_type (arr))->code () == TYPE_CODE_PTR)
arr = value_ind (arr);
type = decode_constrained_packed_array_type (value_type (arr));
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 = value_contents_for_printing (arr);
CORE_ADDR address = value_address (arr);
gdb::array_view<const gdb_byte> view
= gdb::make_array_view (valaddr, TYPE_LENGTH (type));
type = resolve_dynamic_type (type, view, address);
recursively_update_array_bitsize (type);
if (type_byte_order (value_type (arr)) == BFD_ENDIAN_BIG
&& ada_is_modular_type (value_type (arr)))
{
/* 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 (value_type (arr)) - 1;
bit_size = 0;
while (mod > 0)
{
bit_size += 1;
mod >>= 1;
}
bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - 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 (value_type (arr));
for (i = 0; i < arity; i += 1)
{
if (elt_type->code () != TYPE_CODE_ARRAY
|| TYPE_FIELD_BITSIZE (elt_type, 0) == 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 = TYPE_FIELD_BITSIZE (elt_type, 0);
elt_total_bit_offset += (idx - lowerbound) * bits;
elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_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 = value_contents (obj) + 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 (type) < (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 (type) * HOST_CHAR_BIT;
}
}
if (obj == NULL)
{
v = allocate_value (type);
src = valaddr + offset;
}
else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
{
int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
gdb_byte *buf;
v = value_at (type, value_address (obj) + offset);
buf = (gdb_byte *) alloca (src_len);
read_memory (value_address (v), buf, src_len);
src = buf;
}
else
{
v = allocate_value (type);
src = value_contents (obj) + offset;
}
if (obj != NULL)
{
long new_offset = offset;
set_value_component_location (v, obj);
set_value_bitpos (v, bit_offset + value_bitpos (obj));
set_value_bitsize (v, bit_size);
if (value_bitpos (v) >= HOST_CHAR_BIT)
{
++new_offset;
set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
}
set_value_offset (v, new_offset);
/* Also set the parent value. This is needed when trying to
assign a new value (in inferior memory). */
set_value_parent (v, obj);
}
else
set_value_bitsize (v, bit_size);
unpacked = value_contents_writeable (v);
if (bit_size == 0)
{
memset (unpacked, 0, TYPE_LENGTH (type));
return v;
}
if (staging.size () == TYPE_LENGTH (type))
{
/* 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 (type),
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 = value_type (toval);
int bits = value_bitsize (toval);
toval = ada_coerce_ref (toval);
fromval = ada_coerce_ref (fromval);
if (ada_is_direct_array_type (value_type (toval)))
toval = ada_coerce_to_simple_array (toval);
if (ada_is_direct_array_type (value_type (fromval)))
fromval = ada_coerce_to_simple_array (fromval);
if (!deprecated_value_modifiable (toval))
error (_("Left operand of assignment is not a modifiable lvalue."));
if (VALUE_LVAL (toval) == lval_memory
&& bits > 0
&& (type->code () == TYPE_CODE_FLT
|| type->code () == TYPE_CODE_STRUCT))
{
int len = (value_bitpos (toval)
+ 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 = value_address (toval);
if (type->code () == TYPE_CODE_FLT)
fromval = value_cast (type, fromval);
read_memory (to_addr, buffer, len);
from_size = value_bitsize (fromval);
if (from_size == 0)
from_size = TYPE_LENGTH (value_type (fromval)) * 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 (value_type (fromval)))
from_offset = from_size - bits;
copy_bitwise (buffer, value_bitpos (toval),
value_contents (fromval), from_offset,
bits, is_big_endian);
write_memory_with_notification (to_addr, buffer, len);
val = value_copy (toval);
memcpy (value_contents_raw (val), value_contents (fromval),
TYPE_LENGTH (type));
deprecated_set_value_type (val, 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) (value_address (component) - value_address (container));
int bit_offset_in_container =
value_bitpos (component) - value_bitpos (container);
int bits;
val = value_cast (value_type (component), val);
if (value_bitsize (component) == 0)
bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
else
bits = value_bitsize (component);
if (type_byte_order (value_type (container)) == BFD_ENDIAN_BIG)
{
int src_offset;
if (is_scalar_type (check_typedef (value_type (component))))
src_offset
= TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
else
src_offset = 0;
copy_bitwise (value_contents_writeable (container) + offset_in_container,
value_bitpos (container) + bit_offset_in_container,
value_contents (val), src_offset, bits, 1);
}
else
copy_bitwise (value_contents_writeable (container) + offset_in_container,
value_bitpos (container) + bit_offset_in_container,
value_contents (val), 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 (value_type (elt));
if (elt_type->code () == TYPE_CODE_ARRAY
&& TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
return value_subscript_packed (elt, arity, ind);
for (k = 0; k < arity; k += 1)
{
struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_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)
&& value_type (elt)->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. */
deprecated_set_value_type (elt, saved_elt_type);
}
elt_type = ada_check_typedef (value_type (elt));
}
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 (value_enclosing_type (array_ind));
if (type->code () == TYPE_CODE_ARRAY
&& TYPE_FIELD_BITSIZE (type, 0) > 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 (type)),
value_copy (arr));
get_discrete_bounds (type->index_type (), &lwb, &upb);
arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
type = TYPE_TARGET_TYPE (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 = TYPE_TARGET_TYPE (type0->index_type ());
struct type *index_type
= create_static_range_type (NULL, base_index_type, low, high);
struct type *slice_type = create_array_type_with_stride
(NULL, TYPE_TARGET_TYPE (type0), index_type,
type0->dyn_prop (DYN_PROP_BYTE_STRIDE),
TYPE_FIELD_BITSIZE (type0, 0));
int base_low = ada_discrete_type_low_bound (type0->index_type ());
gdb::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 = TYPE_FIELD_BITSIZE (slice_type, 0) / 8;
if (stride == 0)
stride = TYPE_LENGTH (TYPE_TARGET_TYPE (type0));
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 (value_type (array));
struct type *base_index_type = TYPE_TARGET_TYPE (type->index_type ());
struct type *index_type
= create_static_range_type (NULL, type->index_type (), low, high);
struct type *slice_type = create_array_type_with_stride
(NULL, TYPE_TARGET_TYPE (type), index_type,
type->dyn_prop (DYN_PROP_BYTE_STRIDE),
TYPE_FIELD_BITSIZE (type, 0));
gdb::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;
if (type == NULL)
return 0;
type = desc_base_type (type);
arity = 0;
if (type->code () == TYPE_CODE_STRUCT)
return desc_arity (desc_bounds_type (type));
else
while (type->code () == TYPE_CODE_ARRAY)
{
arity += 1;
type = ada_check_typedef (TYPE_TARGET_TYPE (type));
}
return arity;
}
/* If TYPE is a record type in the form of a standard GNAT array
descriptor or a simple array type, returns the element type for
TYPE after indexing by NINDICES indices, or by all indices if
NINDICES is -1. Otherwise, returns NULL. */
struct type *
ada_array_element_type (struct type *type, int nindices)
{
type = desc_base_type (type);
if (type->code () == TYPE_CODE_STRUCT)
{
int k;
struct type *p_array_type;
p_array_type = desc_data_target_type (type);
k = ada_array_arity (type);
if (k == 0)
return NULL;
/* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
if (nindices >= 0 && k > nindices)
k = nindices;
while (k > 0 && p_array_type != NULL)
{
p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
k -= 1;
}
return p_array_type;
}
else if (type->code () == TYPE_CODE_ARRAY)
{
while (nindices != 0 && type->code () == TYPE_CODE_ARRAY)
{
type = TYPE_TARGET_TYPE (type);
nindices -= 1;
}
return type;
}
return NULL;
}
/* See ada-lang.h. */
struct type *
ada_index_type (struct type *type, int n, const char *name)
{
struct type *result_type;
type = desc_base_type (type);
if (n < 0 || n > ada_array_arity (type))
error (_("invalid dimension number to '%s"), name);
if (ada_is_simple_array_type (type))
{
int i;
for (i = 1; i < n; i += 1)
{
type = ada_check_typedef (type);
type = TYPE_TARGET_TYPE (type);
}
result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_type ());
/* FIXME: The stabs type r(0,0);bound;bound in an array type
has a target type of TYPE_CODE_UNDEF. We compensate here, but
perhaps stabsread.c would make more sense. */
if (result_type && result_type->code () == TYPE_CODE_UNDEF)
result_type = NULL;
}
else
{
result_type = desc_index_type (desc_bounds_type (type), n);
if (result_type == NULL)
error (_("attempt to take bound of something that is not an array"));
}
return result_type;
}
/* Given that arr is an array type, returns the lower bound of the
Nth index (numbering from 1) if WHICH is 0, and the upper bound if
WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
array-descriptor type. It works for other arrays with bounds supplied
by run-time quantities other than discriminants. */
static LONGEST
ada_array_bound_from_type (struct type *arr_type, int n, int which)
{
struct type *type, *index_type_desc, *index_type;
int i;
gdb_assert (which == 0 || which == 1);
if (ada_is_constrained_packed_array_type (arr_type))
arr_type = decode_constrained_packed_array_type (arr_type);
if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
return (LONGEST) - which;
if (arr_type->code () == TYPE_CODE_PTR)
type = TYPE_TARGET_TYPE (arr_type);
else
type = arr_type;
if (type->is_fixed_instance ())
{
/* The array has already been fixed, so we do not need to
check the parallel ___XA type again. That encoding has
already been applied, so ignore it now. */
index_type_desc = NULL;
}
else
{
index_type_desc = ada_find_parallel_type (type, "___XA");
ada_fixup_array_indexes_type (index_type_desc);
}
if (index_type_desc != NULL)
index_type = to_fixed_range_type (index_type_desc->field (n - 1).type (),
NULL);
else
{
struct type *elt_type = check_typedef (type);
for (i = 1; i < n; i++)
elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
index_type = elt_type->index_type ();
}
return
(LONGEST) (which == 0
? ada_discrete_type_low_bound (index_type)
: ada_discrete_type_high_bound (index_type));
}
/* Given that arr is an array value, returns the lower bound of the
nth index (numbering from 1) if WHICH is 0, and the upper bound if
WHICH is 1. This routine will also work for arrays with bounds
supplied by run-time quantities other than discriminants. */
static LONGEST
ada_array_bound (struct value *arr, int n, int which)
{
struct type *arr_type;
if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
arr = value_ind (arr);
arr_type = value_enclosing_type (arr);
if (ada_is_constrained_packed_array_type (arr_type))
return ada_array_bound (decode_constrained_packed_array (arr), n, which);
else if (ada_is_simple_array_type (arr_type))
return ada_array_bound_from_type (arr_type, n, which);
else
return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
}
/* Given that arr is an array value, returns the length of the
nth index. This routine will also work for arrays with bounds
supplied by run-time quantities other than discriminants.
Does not work for arrays indexed by enumeration types with representation
clauses at the moment. */
static LONGEST
ada_array_length (struct value *arr, int n)
{
struct type *arr_type, *index_type;
int low, high;
if (check_typedef (value_type (arr))->code () == TYPE_CODE_PTR)
arr = value_ind (arr);
arr_type = value_enclosing_type (arr);
if (ada_is_constrained_packed_array_type (arr_type))
return ada_array_length (decode_constrained_packed_array (arr), n);
if (ada_is_simple_array_type (arr_type))
{
low = ada_array_bound_from_type (arr_type, n, 0);
high = ada_array_bound_from_type (arr_type, n, 1);
}
else
{
low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
}
arr_type = check_typedef (arr_type);
index_type = ada_index_type (arr_type, n, "length");
if (index_type != NULL)
{
struct type *base_type;
if (index_type->code () == TYPE_CODE_RANGE)
base_type = TYPE_TARGET_TYPE (index_type);
else
base_type = index_type;
low = pos_atr (value_from_longest (base_type, low));
high = pos_atr (value_from_longest (base_type, high));
}
return high - low + 1;
}
/* An array whose type is that of ARR_TYPE (an array type), with
bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
less than LOW, then LOW-1 is used. */
static struct value *
empty_array (struct type *arr_type, int low, int high)
{
struct type *arr_type0 = ada_check_typedef (arr_type);
struct type *index_type
= create_static_range_type
(NULL, TYPE_TARGET_TYPE (arr_type0->index_type ()), low,
high < low ? low - 1 : high);
struct type *elt_type = ada_array_element_type (arr_type0, 1);
return allocate_value (create_array_type (NULL, elt_type, index_type));
}
/* Name resolution */
/* The "decoded" name for the user-definable Ada operator corresponding
to OP. */
static const char *
ada_decoded_op_name (enum exp_opcode op)
{
int i;
for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
{
if (ada_opname_table[i].op == op)
return ada_opname_table[i].decoded;
}
error (_("Could not find operator name for opcode"));
}
/* Returns true (non-zero) iff decoded name N0 should appear before N1
in a listing of choices during disambiguation (see sort_choices, below).
The idea is that overloadings of a subprogram name from the
same package should sort in their source order. We settle for ordering
such symbols by their trailing number (__N or $N). */
static int
encoded_ordered_before (const char *N0, const char *N1)
{
if (N1 == NULL)
return 0;
else if (N0 == NULL)
return 1;
else
{
int k0, k1;
for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
;
for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
;
if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
&& (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
{
int n0, n1;
n0 = k0;
while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
n0 -= 1;
n1 = k1;
while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
n1 -= 1;
if (n0 == n1 && strncmp (N0, N1, n0) == 0)
return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
}
return (strcmp (N0, N1) < 0);
}
}
/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
encoded names. */
static void
sort_choices (struct block_symbol syms[], int nsyms)
{
int i;
for (i = 1; i < nsyms; i += 1)
{
struct block_symbol sym = syms[i];
int j;
for (j = i - 1; j >= 0; j -= 1)
{
if (encoded_ordered_before (syms[j].symbol->linkage_name (),
sym.symbol->linkage_name ()))
break;
syms[j