/* Ada language support routines for GDB, the GNU debugger.
- Copyright (C) 1992-2014 Free Software Foundation, Inc.
+ Copyright (C) 1992-2015 Free Software Foundation, Inc.
This file is part of GDB.
#include "defs.h"
-#include <stdio.h>
-#include <string.h>
#include <ctype.h>
-#include <stdarg.h>
#include "demangle.h"
#include "gdb_regex.h"
#include "frame.h"
#include "block.h"
#include "infcall.h"
#include "dictionary.h"
-#include "exceptions.h"
#include "annotate.h"
#include "valprint.h"
#include "source.h"
static void ada_language_arch_info (struct gdbarch *,
struct language_arch_info *);
-static void check_size (const struct type *);
-
static struct value *ada_index_struct_field (int, struct value *, int,
struct type *);
/* The name used to perform the lookup. */
const char *name;
/* The namespace used during the lookup. */
- domain_enum namespace;
+ domain_enum domain;
/* The symbol returned by the lookup, or NULL if no matching symbol
was found. */
struct symbol *sym;
static void
maint_set_ada_cmd (char *args, int from_tty)
{
- help_list (maint_set_ada_cmdlist, "maintenance set ada ", -1, gdb_stdout);
+ help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
+ gdb_stdout);
}
/* Implement the "maintenance show ada" (prefix) command. */
static const char *
ada_unqualified_name (const char *decoded_name)
{
- const char *result = strrchr (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
/* Make sure that the object size is not unreasonable before
trying to allocate some memory for it. */
- check_size (type);
+ ada_ensure_varsize_limit (type);
if (value_lazy (val)
|| TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
else
{
result = allocate_value (type);
- memcpy (value_contents_raw (result), value_contents (val),
- TYPE_LENGTH (type));
+ value_contents_copy_raw (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));
set_value_address (result, value_address (val));
- set_value_optimized_out (result, value_optimized_out_const (val));
return result;
}
}
i.e. if it would be a bad idea to allocate a value of this type in
GDB. */
-static void
-check_size (const struct type *type)
+void
+ada_ensure_varsize_limit (const struct type *type)
{
if (TYPE_LENGTH (type) > varsize_limit)
error (_("object size is larger than varsize-limit"));
LONGEST
ada_discrete_type_high_bound (struct type *type)
{
+ type = resolve_dynamic_type (type, 0);
switch (TYPE_CODE (type))
{
case TYPE_CODE_RANGE:
LONGEST
ada_discrete_type_low_bound (struct type *type)
{
+ type = resolve_dynamic_type (type, 0);
switch (TYPE_CODE (type))
{
case TYPE_CODE_RANGE:
struct value *high = desc_one_bound (descriptor, arity, 1);
arity -= 1;
- create_range_type (range_type, value_type (low),
- longest_to_int (value_as_long (low)),
- longest_to_int (value_as_long (high)));
+ 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)))
if (arrVal == NULL)
error (_("Bounds unavailable for null array pointer."));
- check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
+ ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
return value_ind (arrVal);
}
else if (ada_is_constrained_packed_array_type (value_type (arr)))
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. */
+ 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)
TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
TYPE_NAME (new_type) = ada_type_name (type);
- if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
+ if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
+ && is_dynamic_type (check_typedef (index_type)))
+ || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
low_bound = high_bound = 0;
if (high_bound < low_bound)
*elt_bits = TYPE_LENGTH (new_type) = 0;
else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
{
v = value_at (type, value_address (obj));
+ type = value_type (v);
bytes = (unsigned char *) alloca (len);
read_memory (value_address (v) + offset, bytes, len);
}
return elt;
}
-/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
- value of the element of *ARR at the ARITY indices given in
- IND. Does not read the entire array into memory. */
+/* 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. */
static struct value *
-ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
- struct value **ind)
+ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
{
int k;
+ struct type *type
+ = check_typedef (value_enclosing_type (ada_value_ind (arr)));
for (k = 0; k < arity; k += 1)
{
CORE_ADDR base = value_as_address (array_ptr)
+ ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
* TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
- struct type *index_type =
- create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
- low, high);
+ struct type *index_type
+ = create_static_range_type (NULL,
+ TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
+ low, high);
struct type *slice_type =
create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
ada_value_slice (struct value *array, int low, int high)
{
struct type *type = ada_check_typedef (value_type (array));
- struct type *index_type =
- create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
+ struct type *index_type
+ = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
struct type *slice_type =
create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
else
type = arr_type;
- index_type_desc = ada_find_parallel_type (type, "___XA");
- ada_fixup_array_indexes_type (index_type_desc);
+ if (TYPE_FIXED_INSTANCE (type))
+ {
+ /* 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 (TYPE_FIELD_TYPE (index_type_desc, n - 1),
NULL);
static LONGEST
ada_array_bound (struct value *arr, int n, int which)
{
- struct type *arr_type = value_type (arr);
+ struct type *arr_type;
+
+ if (TYPE_CODE (check_typedef (value_type (arr))) == 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);
static LONGEST
ada_array_length (struct value *arr, int n)
{
- struct type *arr_type = ada_check_typedef (value_type (arr));
+ struct type *arr_type;
+
+ if (TYPE_CODE (check_typedef (value_type (arr))) == 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);
empty_array (struct type *arr_type, int low)
{
struct type *arr_type0 = ada_check_typedef (arr_type);
- struct type *index_type =
- create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),
- low, low - 1);
+ struct type *index_type
+ = create_static_range_type
+ (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
struct type *elt_type = ada_array_element_type (arr_type0, 1);
return allocate_value (create_array_type (NULL, elt_type, index_type));
(SYMBOL_CLASS (syms[i].sym) == LOC_CONST
&& SYMBOL_TYPE (syms[i].sym) != NULL
&& TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
- struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
+ struct symtab *symtab = NULL;
+
+ if (SYMBOL_OBJFILE_OWNED (syms[i].sym))
+ symtab = symbol_symtab (syms[i].sym);
if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
printf_unfiltered (_("[%d] %s at %s:%d\n"),
static struct value *
ada_read_renaming_var_value (struct symbol *renaming_sym,
- struct block *block)
+ const struct block *block)
{
const char *sym_name;
struct expression *expr;
ada_get_symbol_cache (struct program_space *pspace)
{
struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
- struct ada_symbol_cache *sym_cache = pspace_data->sym_cache;
- if (sym_cache == NULL)
+ if (pspace_data->sym_cache == NULL)
{
- sym_cache = XCNEW (struct ada_symbol_cache);
- ada_init_symbol_cache (sym_cache);
+ pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
+ ada_init_symbol_cache (pspace_data->sym_cache);
}
- return sym_cache;
+ return pspace_data->sym_cache;
}
/* Clear all entries from the symbol cache. */
ada_init_symbol_cache (sym_cache);
}
-/* Search our cache for an entry matching NAME and NAMESPACE.
+/* Search our cache for an entry matching NAME and DOMAIN.
Return it if found, or NULL otherwise. */
static struct cache_entry **
-find_entry (const char *name, domain_enum namespace)
+find_entry (const char *name, domain_enum domain)
{
struct ada_symbol_cache *sym_cache
= ada_get_symbol_cache (current_program_space);
for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
{
- if (namespace == (*e)->namespace && strcmp (name, (*e)->name) == 0)
+ if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
return e;
}
return NULL;
}
-/* Search the symbol cache for an entry matching NAME and NAMESPACE.
+/* Search the symbol cache for an entry matching NAME and DOMAIN.
Return 1 if found, 0 otherwise.
If an entry was found and SYM is not NULL, set *SYM to the entry's
SYM. Same principle for BLOCK if not NULL. */
static int
-lookup_cached_symbol (const char *name, domain_enum namespace,
+lookup_cached_symbol (const char *name, domain_enum domain,
struct symbol **sym, const struct block **block)
{
- struct cache_entry **e = find_entry (name, namespace);
+ struct cache_entry **e = find_entry (name, domain);
if (e == NULL)
return 0;
}
/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
- in domain NAMESPACE, save this result in our symbol cache. */
+ in domain DOMAIN, save this result in our symbol cache. */
static void
-cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
+cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
const struct block *block)
{
struct ada_symbol_cache *sym_cache
char *copy;
struct cache_entry *e;
+ /* Symbols for builtin types don't have a block.
+ For now don't cache such symbols. */
+ if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
+ return;
+
/* If the symbol is a local symbol, then do not cache it, as a search
for that symbol depends on the context. To determine whether
the symbol is local or not, we check the block where we found it
against the global and static blocks of its associated symtab. */
if (sym
- && BLOCKVECTOR_BLOCK (BLOCKVECTOR (sym->symtab), GLOBAL_BLOCK) != block
- && BLOCKVECTOR_BLOCK (BLOCKVECTOR (sym->symtab), STATIC_BLOCK) != block)
+ && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
+ GLOBAL_BLOCK) != block
+ && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
+ STATIC_BLOCK) != block)
return;
h = msymbol_hash (name) % HASH_SIZE;
e->name = copy = obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
strcpy (copy, name);
e->sym = sym;
- e->namespace = namespace;
+ e->domain = domain;
e->block = block;
}
\f
static void
add_symbols_from_enclosing_procs (struct obstack *obstackp,
- const char *name, domain_enum namespace,
+ const char *name, domain_enum domain,
int wild_match_p)
{
}
static int
ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
- domain_enum namespace,
+ domain_enum domain,
struct ada_symbol_info **results,
int full_search)
{
const struct block *block;
const char *name;
const int wild_match_p = should_use_wild_match (name0);
- int cacheIfUnique;
+ int syms_from_global_search = 0;
int ndefns;
obstack_free (&symbol_list_obstack, NULL);
obstack_init (&symbol_list_obstack);
- cacheIfUnique = 0;
-
/* Search specified block and its superiors. */
name = name0;
if (full_search)
{
ada_add_local_symbols (&symbol_list_obstack, name, block,
- namespace, wild_match_p);
+ domain, wild_match_p);
}
else
{
ada_iterate_over_symbols, and we don't want to search
superblocks. */
ada_add_block_symbols (&symbol_list_obstack, block, name,
- namespace, NULL, wild_match_p);
+ domain, NULL, wild_match_p);
}
if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
goto done;
already performed this search before. If we have, then return
the same result. */
- cacheIfUnique = 1;
- if (lookup_cached_symbol (name0, namespace, &sym, &block))
+ if (lookup_cached_symbol (name0, domain, &sym, &block))
{
if (sym != NULL)
add_defn_to_vec (&symbol_list_obstack, sym, block);
goto done;
}
+ syms_from_global_search = 1;
+
/* Search symbols from all global blocks. */
- add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
+ add_nonlocal_symbols (&symbol_list_obstack, name, domain, 1,
wild_match_p);
/* Now add symbols from all per-file blocks if we've gotten no hits
(not strictly correct, but perhaps better than an error). */
if (num_defns_collected (&symbol_list_obstack) == 0)
- add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
+ add_nonlocal_symbols (&symbol_list_obstack, name, domain, 0,
wild_match_p);
done:
ndefns = remove_extra_symbols (*results, ndefns);
- if (ndefns == 0 && full_search)
- cache_symbol (name0, namespace, NULL, NULL);
+ if (ndefns == 0 && full_search && syms_from_global_search)
+ cache_symbol (name0, domain, NULL, NULL);
- if (ndefns == 1 && full_search && cacheIfUnique)
- cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
+ if (ndefns == 1 && full_search && syms_from_global_search)
+ cache_symbol (name0, domain, (*results)[0].sym, (*results)[0].block);
ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
void
ada_lookup_encoded_symbol (const char *name, const struct block *block,
- domain_enum namespace,
+ domain_enum domain,
struct ada_symbol_info *info)
{
struct ada_symbol_info *candidates;
gdb_assert (info != NULL);
memset (info, 0, sizeof (struct ada_symbol_info));
- n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates);
+ n_candidates = ada_lookup_symbol_list (name, block, domain, &candidates);
if (n_candidates == 0)
return;
struct symbol *
ada_lookup_symbol (const char *name, const struct block *block0,
- domain_enum namespace, int *is_a_field_of_this)
+ domain_enum domain, int *is_a_field_of_this)
{
struct ada_symbol_info info;
*is_a_field_of_this = 0;
ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
- block0, namespace, &info);
+ block0, domain, &info);
return info.sym;
}
static struct symbol *
-ada_lookup_symbol_nonlocal (const char *name,
+ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
+ const char *name,
const struct block *block,
const domain_enum domain)
{
- return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
+ struct symbol *sym;
+
+ sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
+ if (sym != NULL)
+ return sym;
+
+ /* If we haven't found a match at this point, try the primitive
+ types. In other languages, this search is performed before
+ searching for global symbols in order to short-circuit that
+ global-symbol search if it happens that the name corresponds
+ to a primitive type. But we cannot do the same in Ada, because
+ it is perfectly legitimate for a program to declare a type which
+ has the same name as a standard type. If looking up a type in
+ that situation, we have traditionally ignored the primitive type
+ in favor of user-defined types. This is why, unlike most other
+ languages, we search the primitive types this late and only after
+ having searched the global symbols without success. */
+
+ if (domain == VAR_DOMAIN)
+ {
+ struct gdbarch *gdbarch;
+
+ if (block == NULL)
+ gdbarch = target_gdbarch ();
+ else
+ gdbarch = block_gdbarch (block);
+ sym = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
+ if (sym != NULL)
+ return sym;
+ }
+
+ return NULL;
}
int encoded_p;
VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
struct symbol *sym;
- struct symtab *s;
+ struct compunit_symtab *s;
struct minimal_symbol *msymbol;
struct objfile *objfile;
- struct block *b, *surrounding_static_block = 0;
+ const struct block *b, *surrounding_static_block = 0;
int i;
struct block_iterator iter;
struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
data.word = word;
data.wild_match = wild_match_p;
data.encoded = encoded_p;
- expand_symtabs_matching (NULL, ada_complete_symbol_matcher, ALL_DOMAIN,
- &data);
+ expand_symtabs_matching (NULL, ada_complete_symbol_matcher, NULL,
+ ALL_DOMAIN, &data);
}
/* At this point scan through the misc symbol vectors and add each
/* Go through the symtabs and check the externs and statics for
symbols which match. */
- ALL_SYMTABS (objfile, s)
+ ALL_COMPUNITS (objfile, s)
{
QUIT;
- b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
+ b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
ALL_BLOCK_SYMBOLS (b, iter, sym)
{
symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
}
}
- ALL_SYMTABS (objfile, s)
+ ALL_COMPUNITS (objfile, s)
{
QUIT;
- b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
+ b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
/* Don't do this block twice. */
if (b == surrounding_static_block)
continue;
struct value *discrim;
LONGEST discrim_val;
- outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
+ /* Using plain value_from_contents_and_address here causes problems
+ because we will end up trying to resolve a type that is currently
+ being constructed. */
+ outer = value_from_contents_and_address_unresolved (outer_type,
+ outer_valaddr, 0);
discrim = ada_value_struct_elt (outer, discrim_name, 1);
if (discrim == NULL)
return -1;
ada_find_parallel_type (struct type *type, const char *suffix)
{
char *name;
- const char *typename = ada_type_name (type);
+ const char *type_name = ada_type_name (type);
int len;
- if (typename == NULL)
+ if (type_name == NULL)
return NULL;
- len = strlen (typename);
+ len = strlen (type_name);
name = (char *) alloca (len + strlen (suffix) + 1);
- strcpy (name, typename);
+ strcpy (name, type_name);
strcpy (name + len, suffix);
return ada_find_parallel_type_with_name (type, name);
/* A record type with no fields. */
static struct type *
-empty_record (struct type *template)
+empty_record (struct type *templ)
{
- struct type *type = alloc_type_copy (template);
+ struct type *type = alloc_type_copy (templ);
TYPE_CODE (type) = TYPE_CODE_STRUCT;
TYPE_NFIELDS (type) = 0;
initialized, the type size may be completely bogus and
GDB may fail to allocate a value for it. So check the
size first before creating the value. */
- check_size (rtype);
- dval = value_from_contents_and_address (rtype, valaddr, address);
+ ada_ensure_varsize_limit (rtype);
+ /* Using plain value_from_contents_and_address here
+ causes problems because we will end up trying to
+ resolve a type that is currently being
+ constructed. */
+ dval = value_from_contents_and_address_unresolved (rtype,
+ valaddr,
+ address);
+ rtype = value_type (dval);
}
else
dval = dval0;
large (due to an uninitialized variable in the inferior)
that it would cause an overflow when adding it to the
record size. */
- check_size (field_type);
+ ada_ensure_varsize_limit (field_type);
TYPE_FIELD_TYPE (rtype, f) = field_type;
TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
off = TYPE_FIELD_BITPOS (rtype, variant_field);
if (dval0 == NULL)
- dval = value_from_contents_and_address (rtype, valaddr, address);
+ {
+ /* Using plain value_from_contents_and_address here causes
+ problems because we will end up trying to resolve a type
+ that is currently being constructed. */
+ dval = value_from_contents_and_address_unresolved (rtype, valaddr,
+ address);
+ rtype = value_type (dval);
+ }
else
dval = dval0;
return type;
if (dval0 == NULL)
- dval = value_from_contents_and_address (type, valaddr, address);
+ {
+ dval = value_from_contents_and_address (type, valaddr, address);
+ type = value_type (dval);
+ }
else
dval = dval0;
return TYPE_FIELD_TYPE (var_type, which);
}
+/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
+ ENCODING_TYPE, a type following the GNAT conventions for discrete
+ type encodings, only carries redundant information. */
+
+static int
+ada_is_redundant_range_encoding (struct type *range_type,
+ struct type *encoding_type)
+{
+ struct type *fixed_range_type;
+ char *bounds_str;
+ int n;
+ LONGEST lo, hi;
+
+ gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
+
+ if (TYPE_CODE (get_base_type (range_type))
+ != TYPE_CODE (get_base_type (encoding_type)))
+ {
+ /* The compiler probably used a simple base type to describe
+ the range type instead of the range's actual base type,
+ expecting us to get the real base type from the encoding
+ anyway. In this situation, the encoding cannot be ignored
+ as redundant. */
+ return 0;
+ }
+
+ if (is_dynamic_type (range_type))
+ return 0;
+
+ if (TYPE_NAME (encoding_type) == NULL)
+ return 0;
+
+ bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
+ if (bounds_str == NULL)
+ return 0;
+
+ n = 8; /* Skip "___XDLU_". */
+ if (!ada_scan_number (bounds_str, n, &lo, &n))
+ return 0;
+ if (TYPE_LOW_BOUND (range_type) != lo)
+ return 0;
+
+ n += 2; /* Skip the "__" separator between the two bounds. */
+ if (!ada_scan_number (bounds_str, n, &hi, &n))
+ return 0;
+ if (TYPE_HIGH_BOUND (range_type) != hi)
+ return 0;
+
+ return 1;
+}
+
+/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
+ a type following the GNAT encoding for describing array type
+ indices, only carries redundant information. */
+
+static int
+ada_is_redundant_index_type_desc (struct type *array_type,
+ struct type *desc_type)
+{
+ struct type *this_layer = check_typedef (array_type);
+ int i;
+
+ for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
+ {
+ if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
+ TYPE_FIELD_TYPE (desc_type, i)))
+ return 0;
+ this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
+ }
+
+ return 1;
+}
+
/* Assuming that TYPE0 is an array type describing the type of a value
at ADDR, and that DVAL describes a record containing any
discriminants used in TYPE0, returns a type for the value that
index_type_desc = ada_find_parallel_type (type0, "___XA");
ada_fixup_array_indexes_type (index_type_desc);
+ if (index_type_desc != NULL
+ && ada_is_redundant_index_type_desc (type0, index_type_desc))
+ {
+ /* Ignore this ___XA parallel type, as it does not bring any
+ useful information. This allows us to avoid creating fixed
+ versions of the array's index types, which would be identical
+ to the original ones. This, in turn, can also help avoid
+ the creation of fixed versions of the array itself. */
+ index_type_desc = NULL;
+ }
+
if (index_type_desc == NULL)
{
struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
value_from_contents_and_address (fixed_record_type,
valaddr,
address);
+ fixed_record_type = value_type (obj);
if (real_type != NULL)
return to_fixed_record_type
(real_type, NULL,
return (value_from_longest
(value_type (arg1),
value_as_long (arg1) + value_as_long (arg2)));
+ if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
+ return (value_from_longest
+ (value_type (arg2),
+ value_as_long (arg1) + value_as_long (arg2)));
if ((ada_is_fixed_point_type (value_type (arg1))
|| ada_is_fixed_point_type (value_type (arg2)))
&& value_type (arg1) != value_type (arg2))
return (value_from_longest
(value_type (arg1),
value_as_long (arg1) - value_as_long (arg2)));
+ if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
+ return (value_from_longest
+ (value_type (arg2),
+ value_as_long (arg1) - value_as_long (arg2)));
if ((ada_is_fixed_point_type (value_type (arg1))
|| ada_is_fixed_point_type (value_type (arg2)))
&& value_type (arg1) != value_type (arg2))
*pos += 4;
goto nosideret;
}
- else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
+
+ if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
/* Only encountered when an unresolved symbol occurs in a
context other than a function call, in which case, it is
invalid. */
error (_("Unexpected unresolved symbol, %s, during evaluation"),
SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
{
type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
/* Check to see if this is a tagged type. We also need to handle
if (ada_is_tagged_type (type, 0)
|| (TYPE_CODE (type) == TYPE_CODE_REF
&& ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
- {
- /* Tagged types are a little special in the fact that the real
- type is dynamic and can only be determined by inspecting the
- object's tag. This means that we need to get the object's
- value first (EVAL_NORMAL) and then extract the actual object
- type from its tag.
-
- Note that we cannot skip the final step where we extract
- the object type from its tag, because the EVAL_NORMAL phase
- results in dynamic components being resolved into fixed ones.
- This can cause problems when trying to print the type
- description of tagged types whose parent has a dynamic size:
- We use the type name of the "_parent" component in order
- to print the name of the ancestor type in the type description.
- If that component had a dynamic size, the resolution into
- a fixed type would result in the loss of that type name,
- thus preventing us from printing the name of the ancestor
- type in the type description. */
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
-
- if (TYPE_CODE (type) != TYPE_CODE_REF)
- {
- struct type *actual_type;
-
- actual_type = type_from_tag (ada_value_tag (arg1));
- if (actual_type == NULL)
- /* If, for some reason, we were unable to determine
- the actual type from the tag, then use the static
- approximation that we just computed as a fallback.
- This can happen if the debugging information is
- incomplete, for instance. */
- actual_type = type;
- return value_zero (actual_type, not_lval);
- }
- else
- {
- /* In the case of a ref, ada_coerce_ref takes care
- of determining the actual type. But the evaluation
- should return a ref as it should be valid to ask
- for its address; so rebuild a ref after coerce. */
- arg1 = ada_coerce_ref (arg1);
- return value_ref (arg1);
- }
- }
+ {
+ /* Tagged types are a little special in the fact that the real
+ type is dynamic and can only be determined by inspecting the
+ object's tag. This means that we need to get the object's
+ value first (EVAL_NORMAL) and then extract the actual object
+ type from its tag.
+
+ Note that we cannot skip the final step where we extract
+ the object type from its tag, because the EVAL_NORMAL phase
+ results in dynamic components being resolved into fixed ones.
+ This can cause problems when trying to print the type
+ description of tagged types whose parent has a dynamic size:
+ We use the type name of the "_parent" component in order
+ to print the name of the ancestor type in the type description.
+ If that component had a dynamic size, the resolution into
+ a fixed type would result in the loss of that type name,
+ thus preventing us from printing the name of the ancestor
+ type in the type description. */
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
+
+ if (TYPE_CODE (type) != TYPE_CODE_REF)
+ {
+ struct type *actual_type;
+
+ actual_type = type_from_tag (ada_value_tag (arg1));
+ if (actual_type == NULL)
+ /* If, for some reason, we were unable to determine
+ the actual type from the tag, then use the static
+ approximation that we just computed as a fallback.
+ This can happen if the debugging information is
+ incomplete, for instance. */
+ actual_type = type;
+ return value_zero (actual_type, not_lval);
+ }
+ else
+ {
+ /* In the case of a ref, ada_coerce_ref takes care
+ of determining the actual type. But the evaluation
+ should return a ref as it should be valid to ask
+ for its address; so rebuild a ref after coerce. */
+ arg1 = ada_coerce_ref (arg1);
+ return value_ref (arg1);
+ }
+ }
- *pos += 4;
- return value_zero
- (to_static_fixed_type
- (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
- not_lval);
- }
- else
- {
- arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
- return ada_to_fixed_value (arg1);
+ /* Records and unions for which GNAT encodings have been
+ generated need to be statically fixed as well.
+ Otherwise, non-static fixing produces a type where
+ all dynamic properties are removed, which prevents "ptype"
+ from being able to completely describe the type.
+ For instance, a case statement in a variant record would be
+ replaced by the relevant components based on the actual
+ value of the discriminants. */
+ if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
+ && dynamic_template_type (type) != NULL)
+ || (TYPE_CODE (type) == TYPE_CODE_UNION
+ && ada_find_parallel_type (type, "___XVU") != NULL))
+ {
+ *pos += 4;
+ return value_zero (to_static_fixed_type (type), not_lval);
+ }
}
+ arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
+ return ada_to_fixed_value (arg1);
+
case OP_FUNCALL:
(*pos) += 2;
(ada_coerce_to_simple_array (argvec[0]),
nargs, argvec + 1));
case TYPE_CODE_PTR: /* Pointer to array */
- type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
if (noside == EVAL_AVOID_SIDE_EFFECTS)
{
+ type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
type = ada_array_element_type (type, nargs);
if (type == NULL)
error (_("element type of array unknown"));
return value_zero (ada_aligned_type (type), lval_memory);
}
return
- unwrap_value (ada_value_ptr_subscript (argvec[0], type,
- nargs, argvec + 1));
+ unwrap_value (ada_value_ptr_subscript (argvec[0],
+ nargs, argvec + 1));
default:
error (_("Attempt to index or call something other than an "
(ada_aligned_type
(ada_check_typedef (TYPE_TARGET_TYPE (type))));
}
- check_size (type);
+ ada_ensure_varsize_limit (type);
return value_zero (type, lval_memory);
}
else if (TYPE_CODE (type) == TYPE_CODE_INT)
if (L < INT_MIN || U > INT_MAX)
return raw_type;
else
- return create_range_type (alloc_type_copy (raw_type), raw_type,
- ada_discrete_type_low_bound (raw_type),
- ada_discrete_type_high_bound (raw_type));
+ return create_static_range_type (alloc_type_copy (raw_type), raw_type,
+ L, U);
}
else
{
}
}
- type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
+ type = create_static_range_type (alloc_type_copy (raw_type),
+ base_type, L, U);
TYPE_NAME (type) = name;
return type;
}
variants of the runtime, we use a sniffer that will determine
the runtime variant used by the program being debugged. */
-/* Ada's standard exceptions. */
+/* Ada's standard exceptions.
+
+ The Ada 83 standard also defined Numeric_Error. But there so many
+ situations where it was unclear from the Ada 83 Reference Manual
+ (RM) whether Constraint_Error or Numeric_Error should be raised,
+ that the ARG (Ada Rapporteur Group) eventually issued a Binding
+ Interpretation saying that anytime the RM says that Numeric_Error
+ should be raised, the implementation may raise Constraint_Error.
+ Ada 95 went one step further and pretty much removed Numeric_Error
+ from the list of standard exceptions (it made it a renaming of
+ Constraint_Error, to help preserve compatibility when compiling
+ an Ada83 compiler). As such, we do not include Numeric_Error from
+ this list of standard exceptions. */
static char *standard_exc[] = {
"constraint_error",
re_comp (known_runtime_file_name_patterns[i]);
if (re_exec (lbasename (sal.symtab->filename)))
return 1;
- if (sal.symtab->objfile != NULL
- && re_exec (objfile_name (sal.symtab->objfile)))
+ if (SYMTAB_OBJFILE (sal.symtab) != NULL
+ && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
return 1;
}
ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
VEC(ada_exc_info) **exceptions)
{
- struct block *block = get_frame_block (frame, 0);
+ const struct block *block = get_frame_block (frame, 0);
while (block != 0)
{
ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
{
struct objfile *objfile;
- struct symtab *s;
+ struct compunit_symtab *s;
- expand_symtabs_matching (NULL, ada_exc_search_name_matches,
+ expand_symtabs_matching (NULL, ada_exc_search_name_matches, NULL,
VARIABLES_DOMAIN, preg);
- ALL_PRIMARY_SYMTABS (objfile, s)
+ ALL_COMPUNITS (objfile, s)
{
- struct blockvector *bv = BLOCKVECTOR (s);
+ const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
int i;
for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
}
static int
-parse (void)
+parse (struct parser_state *ps)
{
warnings_issued = 0;
- return ada_parse ();
+ return ada_parse (ps);
}
static const struct exp_descriptor ada_exp_descriptor = {
static struct value *
ada_read_var_value (struct symbol *var, struct frame_info *frame)
{
- struct block *frame_block = NULL;
+ const struct block *frame_block = NULL;
struct symbol *renaming_sym = NULL;
/* The only case where default_read_var_value is not sufficient
ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
ada_iterate_over_symbols,
&ada_varobj_ops,
+ NULL,
+ NULL,
LANG_MAGIC
};
{
printf_unfiltered (_(\
"\"set ada\" must be followed by the name of a setting.\n"));
- help_list (set_ada_list, "set ada ", -1, gdb_stdout);
+ help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
}
/* Implement the "show ada" prefix command. */
projects / deliverable / binutils-gdb.git / blobdiff