#include "vec.h"
#include "stack.h"
#include "gdb_vecs.h"
+#include "typeprint.h"
#include "psymtab.h"
#include "value.h"
static void ada_forward_operator_length (struct expression *, int, int *,
int *);
+
+static struct type *ada_find_any_type (const char *name);
\f
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 (val));
return result;
}
}
case TYPE_CODE_RANGE:
return TYPE_HIGH_BOUND (type);
case TYPE_CODE_ENUM:
- return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
+ return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
case TYPE_CODE_BOOL:
return 1;
case TYPE_CODE_CHAR:
}
}
-/* The largest value in the domain of TYPE, a discrete type, as an integer. */
+/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
LONGEST
ada_discrete_type_low_bound (struct type *type)
{
case TYPE_CODE_RANGE:
return TYPE_LOW_BOUND (type);
case TYPE_CODE_ENUM:
- return TYPE_FIELD_BITPOS (type, 0);
+ return TYPE_FIELD_ENUMVAL (type, 0);
case TYPE_CODE_BOOL:
return 0;
case TYPE_CODE_CHAR:
}
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
+ encondings, 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) != TYPE_CODE_PTR))
+ {
+ if (TYPE_CODE (type) == 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;
+}
+
\f
/* Language Selection */
{
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) != TYPE_CODE_ARRAY)
return type;
+ index_type_desc = ada_find_parallel_type (type, "___XA");
+ if (index_type_desc)
+ index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
+ NULL);
+ else
+ index_type = TYPE_INDEX_TYPE (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, TYPE_INDEX_TYPE (type));
+ create_array_type (new_type, new_elt_type, index_type);
TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
TYPE_NAME (new_type) = ada_type_name (type);
- if (get_discrete_bounds (TYPE_INDEX_TYPE (type),
- &low_bound, &high_bound) < 0)
+ if (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) + offset);
+ v = value_at (type, value_address (obj));
bytes = (unsigned char *) alloca (len);
- read_memory (value_address (v), bytes, len);
+ read_memory (value_address (v) + offset, bytes, len);
}
else
{
if (obj != NULL)
{
- CORE_ADDR new_addr;
+ long new_offset = offset;
set_value_component_location (v, obj);
- new_addr = value_address (obj) + offset;
set_value_bitpos (v, bit_offset + value_bitpos (obj));
set_value_bitsize (v, bit_size);
if (value_bitpos (v) >= HOST_CHAR_BIT)
{
- ++new_addr;
+ ++new_offset;
set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
}
- set_value_address (v, new_addr);
+ 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);
+ value_incref (obj);
}
else
set_value_bitsize (v, bit_size);
else
move_bits (buffer, value_bitpos (toval),
value_contents (fromval), 0, bits, 0);
- write_memory (to_addr, buffer, len);
- observer_notify_memory_changed (to_addr, len, buffer);
+ write_memory_with_notification (to_addr, buffer, len);
val = value_copy (toval);
memcpy (value_contents_raw (val), value_contents (fromval),
{
printf_unfiltered (("[%d] "), i + first_choice);
ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
- gdb_stdout, -1, 0);
+ gdb_stdout, -1, 0, &type_print_raw_options);
printf_unfiltered (_("'(%s) (enumeral)\n"),
SYMBOL_PRINT_NAME (syms[i].sym));
}
if (len != NULL)
*len = suffix - info;
return kind;
-}
+}
+/* Compute the value of the given RENAMING_SYM, which is expected to
+ be a symbol encoding a renaming expression. BLOCK is the block
+ used to evaluate the renaming. */
+
+static struct value *
+ada_read_renaming_var_value (struct symbol *renaming_sym,
+ struct block *block)
+{
+ char *sym_name;
+ struct expression *expr;
+ struct value *value;
+ struct cleanup *old_chain = NULL;
+
+ sym_name = xstrdup (SYMBOL_LINKAGE_NAME (renaming_sym));
+ old_chain = make_cleanup (xfree, sym_name);
+ expr = parse_exp_1 (&sym_name, 0, block, 0);
+ make_cleanup (free_current_contents, &expr);
+ value = evaluate_expression (expr);
+
+ do_cleanups (old_chain);
+ return value;
+}
\f
/* Evaluation: Function Calls */
}
else
return actual;
- return value_cast_pointers (formal_type, result);
+ return value_cast_pointers (formal_type, result, 0);
}
else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
return ada_value_ind (actual);
standard_lookup (const char *name, const struct block *block,
domain_enum domain)
{
- struct symbol *sym;
+ /* Initialize it just to avoid a GCC false warning. */
+ struct symbol *sym = NULL;
if (lookup_cached_symbol (name, domain, &sym, NULL))
return sym;
}
/* Return a minimal symbol matching NAME according to Ada decoding
- rules. Returns NULL if there is no such minimal symbol. Names
- prefixed with "standard__" are handled specially: "standard__" is
+ rules. Returns NULL if there is no such minimal symbol. Names
+ prefixed with "standard__" are handled specially: "standard__" is
first stripped off, and only static and global symbols are searched. */
struct minimal_symbol *
{
struct objfile *objfile;
struct minimal_symbol *msymbol;
- const int wild_match = should_use_wild_match (name);
+ const int wild_match_p = should_use_wild_match (name);
/* Special case: If the user specifies a symbol name inside package
Standard, do a non-wild matching of the symbol name without
ALL_MSYMBOLS (objfile, msymbol)
{
- if (match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
+ if (match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
&& MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
return msymbol;
}
/* For all subprograms that statically enclose the subprogram of the
selected frame, add symbols matching identifier NAME in DOMAIN
and their blocks to the list of data in OBSTACKP, as for
- ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
- wildcard prefix. */
+ ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
+ with a wildcard prefix. */
static void
add_symbols_from_enclosing_procs (struct obstack *obstackp,
const char *name, domain_enum namespace,
- int wild_match)
+ int wild_match_p)
{
}
/* All enums in the type should have an identical underlying value. */
for (i = 0; i < TYPE_NFIELDS (type1); i++)
- if (TYPE_FIELD_BITPOS (type1, i) != TYPE_FIELD_BITPOS (type2, i))
+ if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
return 0;
/* All enumerals should also have the same name (modulo any numerical
If no match was found, then extend the search to "enclosing"
routines (in other words, if we're inside a nested function,
search the symbols defined inside the enclosing functions).
+ If WILD_MATCH_P is nonzero, perform the naming matching in
+ "wild" mode (see function "wild_match" for more info).
Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
static void
ada_add_local_symbols (struct obstack *obstackp, const char *name,
struct block *block, domain_enum domain,
- int wild_match)
+ int wild_match_p)
{
int block_depth = 0;
while (block != NULL)
{
block_depth += 1;
- ada_add_block_symbols (obstackp, block, name, domain, NULL, wild_match);
+ ada_add_block_symbols (obstackp, block, name, domain, NULL,
+ wild_match_p);
/* If we found a non-function match, assume that's the one. */
if (is_nonfunction (defns_collected (obstackp, 0),
/* If no luck so far, try to find NAME as a local symbol in some lexically
enclosing subprogram. */
if (num_defns_collected (obstackp) == 0 && block_depth > 2)
- add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match);
+ add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
}
/* An object of this type is used as the user_data argument when
}
/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
- scope and in global scopes, returning the number of matches. Sets
- *RESULTS to point to a vector of (SYM,BLOCK) tuples,
+ scope and in global scopes, returning the number of matches.
+ Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
indicating the symbols found and the blocks and symbol tables (if
- any) in which they were found. This vector are transient---good only to
- the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
+ any) in which they were found. This vector are transient---good only to
+ the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
symbol match within the nest of blocks whose innermost member is BLOCK0,
is the one match returned (no other matches in that or
enclosing blocks is returned). If there are any matches in or
surrounding BLOCK0, then these alone are returned. Otherwise, if
FULL_SEARCH is non-zero, then the search extends to global and
file-scope (static) symbol tables.
- Names prefixed with "standard__" are handled specially: "standard__"
+ Names prefixed with "standard__" are handled specially: "standard__"
is first stripped off, and only static and global symbols are searched. */
int
struct symbol *sym;
struct block *block;
const char *name;
- const int wild_match = should_use_wild_match (name0);
+ const int wild_match_p = should_use_wild_match (name0);
int cacheIfUnique;
int ndefns;
/* Check the non-global symbols. If we have ANY match, then we're done. */
ada_add_local_symbols (&symbol_list_obstack, name, block, namespace,
- wild_match);
+ wild_match_p);
if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
goto done;
/* Search symbols from all global blocks. */
add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
- wild_match);
+ 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,
- wild_match);
+ wild_match_p);
done:
ndefns = num_defns_collected (&symbol_list_obstack);
ndefns = remove_extra_symbols (*results, ndefns);
- if (ndefns == 0)
+ if (ndefns == 0 && full_search)
cache_symbol (name0, namespace, NULL, NULL);
- if (ndefns == 1 && cacheIfUnique)
+ if (ndefns == 1 && full_search && cacheIfUnique)
cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
}
}
-struct symbol *
-ada_lookup_encoded_symbol (const char *name, const struct block *block0,
- domain_enum namespace, struct block **block_found)
+/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
+ to 1, but choosing the first symbol found if there are multiple
+ choices.
+
+ The result is stored in *INFO, which must be non-NULL.
+ If no match is found, INFO->SYM is set to NULL. */
+
+void
+ada_lookup_encoded_symbol (const char *name, const struct block *block,
+ domain_enum namespace,
+ struct ada_symbol_info *info)
{
struct ada_symbol_info *candidates;
int n_candidates;
- n_candidates = ada_lookup_symbol_list (name, block0, namespace, &candidates,
+ gdb_assert (info != NULL);
+ memset (info, 0, sizeof (struct ada_symbol_info));
+
+ n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates,
1);
if (n_candidates == 0)
- return NULL;
-
- if (block_found != NULL)
- *block_found = candidates[0].block;
+ return;
- return fixup_symbol_section (candidates[0].sym, NULL);
-}
+ *info = candidates[0];
+ info->sym = fixup_symbol_section (info->sym, NULL);
+}
/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
scope and in global scopes, or NULL if none. NAME is folded and
encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
choosing the first symbol if there are multiple choices.
- *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
- table in which the symbol was found (in both cases, these
- assignments occur only if the pointers are non-null). */
+ If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
+
struct symbol *
ada_lookup_symbol (const char *name, const struct block *block0,
domain_enum namespace, int *is_a_field_of_this)
{
+ struct ada_symbol_info info;
+
if (is_a_field_of_this != NULL)
*is_a_field_of_this = 0;
- return
- ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
- block0, namespace, NULL);
+ ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
+ block0, namespace, &info);
+ return info.sym;
}
static struct symbol *
static int
wild_match (const char *name, const char *patn)
{
- const char *p, *n;
+ const char *p;
const char *name0 = name;
while (1)
domain_enum domain, struct objfile *objfile,
int wild)
{
- struct dict_iterator iter;
+ struct block_iterator iter;
int name_len = strlen (name);
/* A matching argument symbol, if any. */
struct symbol *arg_sym;
found_sym = 0;
if (wild)
{
- for (sym = dict_iter_match_first (BLOCK_DICT (block), name,
- wild_match, &iter);
- sym != NULL; sym = dict_iter_match_next (name, wild_match, &iter))
+ for (sym = block_iter_match_first (block, name, wild_match, &iter);
+ sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
{
if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
SYMBOL_DOMAIN (sym), domain)
}
else
{
- for (sym = dict_iter_match_first (BLOCK_DICT (block), name,
- full_match, &iter);
- sym != NULL; sym = dict_iter_match_next (name, full_match, &iter))
+ for (sym = block_iter_match_first (block, name, full_match, &iter);
+ sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
{
if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
SYMBOL_DOMAIN (sym), domain))
does not need to be deallocated, but is only good until the next call.
TEXT_LEN is equal to the length of TEXT.
- Perform a wild match if WILD_MATCH is set.
- ENCODED should be set if TEXT represents the start of a symbol name
+ Perform a wild match if WILD_MATCH_P is set.
+ ENCODED_P should be set if TEXT represents the start of a symbol name
in its encoded form. */
static const char *
symbol_completion_match (const char *sym_name,
const char *text, int text_len,
- int wild_match, int encoded)
+ int wild_match_p, int encoded_p)
{
const int verbatim_match = (text[0] == '<');
int match = 0;
if (strncmp (sym_name, text, text_len) == 0)
match = 1;
- if (match && !encoded)
+ if (match && !encoded_p)
{
/* One needed check before declaring a positive match is to verify
that iff we are doing a verbatim match, the decoded version
/* Second: Try wild matching... */
- if (!match && wild_match)
+ if (!match && wild_match_p)
{
/* Since we are doing wild matching, this means that TEXT
may represent an unqualified symbol name. We therefore must
if (verbatim_match)
sym_name = add_angle_brackets (sym_name);
- if (!encoded)
+ if (!encoded_p)
sym_name = ada_decode (sym_name);
return sym_name;
completion should be performed. These two parameters are used to
determine which part of the symbol name should be added to the
completion vector.
- if WILD_MATCH is set, then wild matching is performed.
- ENCODED should be set if TEXT represents a symbol name in its
+ if WILD_MATCH_P is set, then wild matching is performed.
+ ENCODED_P should be set if TEXT represents a symbol name in its
encoded formed (in which case the completion should also be
encoded). */
const char *sym_name,
const char *text, int text_len,
const char *orig_text, const char *word,
- int wild_match, int encoded)
+ int wild_match_p, int encoded_p)
{
const char *match = symbol_completion_match (sym_name, text, text_len,
- wild_match, encoded);
+ wild_match_p, encoded_p);
char *completion;
if (match == NULL)
data->wild_match, data->encoded) != NULL;
}
-/* Return a list of possible symbol names completing TEXT0. The list
- is NULL terminated. WORD is the entire command on which completion
- is made. */
+/* Return a list of possible symbol names completing TEXT0. WORD is
+ the entire command on which completion is made. */
-static char **
+static VEC (char_ptr) *
ada_make_symbol_completion_list (char *text0, char *word)
{
char *text;
int text_len;
- int wild_match;
- int encoded;
+ int wild_match_p;
+ int encoded_p;
VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
struct symbol *sym;
struct symtab *s;
struct objfile *objfile;
struct block *b, *surrounding_static_block = 0;
int i;
- struct dict_iterator iter;
+ struct block_iterator iter;
if (text0[0] == '<')
{
text = xstrdup (text0);
make_cleanup (xfree, text);
text_len = strlen (text);
- wild_match = 0;
- encoded = 1;
+ wild_match_p = 0;
+ encoded_p = 1;
}
else
{
for (i = 0; i < text_len; i++)
text[i] = tolower (text[i]);
- encoded = (strstr (text0, "__") != NULL);
+ encoded_p = (strstr (text0, "__") != NULL);
/* If the name contains a ".", then the user is entering a fully
qualified entity name, and the match must not be done in wild
mode. Similarly, if the user wants to complete what looks like
an encoded name, the match must not be done in wild mode. */
- wild_match = (strchr (text0, '.') == NULL && !encoded);
+ wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
}
/* First, look at the partial symtab symbols. */
data.text_len = text_len;
data.text0 = text0;
data.word = word;
- data.wild_match = wild_match;
- data.encoded = encoded;
+ data.wild_match = wild_match_p;
+ data.encoded = encoded_p;
expand_partial_symbol_names (ada_expand_partial_symbol_name, &data);
}
{
QUIT;
symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
- text, text_len, text0, word, wild_match, encoded);
+ text, text_len, text0, word, wild_match_p,
+ encoded_p);
}
/* Search upwards from currently selected frame (so that we can
{
symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
text, text_len, text0, word,
- wild_match, encoded);
+ wild_match_p, encoded_p);
}
}
{
symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
text, text_len, text0, word,
- wild_match, encoded);
+ wild_match_p, encoded_p);
}
}
{
symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
text, text_len, text0, word,
- wild_match, encoded);
+ wild_match_p, encoded_p);
}
}
- /* Append the closing NULL entry. */
- VEC_safe_push (char_ptr, completions, NULL);
-
- /* Make a copy of the COMPLETIONS VEC before we free it, and then
- return the copy. It's unfortunate that we have to make a copy
- of an array that we're about to destroy, but there is nothing much
- we can do about it. Fortunately, it's typically not a very large
- array. */
- {
- const size_t completions_size =
- VEC_length (char_ptr, completions) * sizeof (char *);
- char **result = xmalloc (completions_size);
-
- memcpy (result, VEC_address (char_ptr, completions), completions_size);
-
- VEC_free (char_ptr, completions);
- return result;
- }
+ return completions;
}
/* Field Access */
{
if (field_num < 0 || field_num > TYPE_NFIELDS (type))
return 1;
-
+
/* Check the name of that field. */
{
const char *name = TYPE_FIELD_NAME (type, field_num);
if (name == NULL)
return 1;
- /* A field named "_parent" is internally generated by GNAT for
- tagged types, and should not be printed either. */
+ /* Normally, fields whose name start with an underscore ("_")
+ are fields that have been internally generated by the compiler,
+ and thus should not be printed. The "_parent" field is special,
+ however: This is a field internally generated by the compiler
+ for tagged types, and it contains the components inherited from
+ the parent type. This field should not be printed as is, but
+ should not be ignored either. */
if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
return 1;
}
return NULL;
}
-struct tag_args
+/* Return the "ada__tags__type_specific_data" type. */
+
+static struct type *
+ada_get_tsd_type (struct inferior *inf)
{
- struct value *tag;
- char *name;
-};
+ struct ada_inferior_data *data = get_ada_inferior_data (inf);
+ if (data->tsd_type == 0)
+ data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
+ return data->tsd_type;
+}
-static int ada_tag_name_1 (void *);
-static int ada_tag_name_2 (struct tag_args *);
+/* Return the TSD (type-specific data) associated to the given TAG.
+ TAG is assumed to be the tag of a tagged-type entity.
-/* Wrapper function used by ada_tag_name. Given a struct tag_args*
- value ARGS, sets ARGS->name to the tag name of ARGS->tag.
- The value stored in ARGS->name is valid until the next call to
- ada_tag_name_1. */
+ May return NULL if we are unable to get the TSD. */
-static int
-ada_tag_name_1 (void *args0)
+static struct value *
+ada_get_tsd_from_tag (struct value *tag)
{
- struct tag_args *args = (struct tag_args *) args0;
- static char name[1024];
- char *p;
struct value *val;
+ struct type *type;
- args->name = NULL;
- val = ada_value_struct_elt (args->tag, "tsd", 1);
- if (val == NULL)
- return ada_tag_name_2 (args);
- val = ada_value_struct_elt (val, "expanded_name", 1);
- if (val == NULL)
- return 0;
- read_memory_string (value_as_address (val), name, sizeof (name) - 1);
- for (p = name; *p != '\0'; p += 1)
- if (isalpha (*p))
- *p = tolower (*p);
- args->name = name;
- return 0;
-}
+ /* First option: The TSD is simply stored as a field of our TAG.
+ Only older versions of GNAT would use this format, but we have
+ to test it first, because there are no visible markers for
+ the current approach except the absence of that field. */
-/* Return the "ada__tags__type_specific_data" type. */
+ val = ada_value_struct_elt (tag, "tsd", 1);
+ if (val)
+ return val;
-static struct type *
-ada_get_tsd_type (struct inferior *inf)
-{
- struct ada_inferior_data *data = get_ada_inferior_data (inf);
+ /* Try the second representation for the dispatch table (in which
+ there is no explicit 'tsd' field in the referent of the tag pointer,
+ and instead the tsd pointer is stored just before the dispatch
+ table. */
- if (data->tsd_type == 0)
- data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
- return data->tsd_type;
+ type = ada_get_tsd_type (current_inferior());
+ if (type == NULL)
+ return NULL;
+ type = lookup_pointer_type (lookup_pointer_type (type));
+ val = value_cast (type, tag);
+ if (val == NULL)
+ return NULL;
+ return value_ind (value_ptradd (val, -1));
}
-/* Utility function for ada_tag_name_1 that tries the second
- representation for the dispatch table (in which there is no
- explicit 'tsd' field in the referent of the tag pointer, and instead
- the tsd pointer is stored just before the dispatch table. */
-
-static int
-ada_tag_name_2 (struct tag_args *args)
+/* Given the TSD of a tag (type-specific data), return a string
+ containing the name of the associated type.
+
+ The returned value is good until the next call. May return NULL
+ if we are unable to determine the tag name. */
+
+static char *
+ada_tag_name_from_tsd (struct value *tsd)
{
- struct type *info_type;
static char name[1024];
char *p;
- struct value *val, *valp;
+ struct value *val;
- args->name = NULL;
- info_type = ada_get_tsd_type (current_inferior());
- if (info_type == NULL)
- return 0;
- info_type = lookup_pointer_type (lookup_pointer_type (info_type));
- valp = value_cast (info_type, args->tag);
- if (valp == NULL)
- return 0;
- val = value_ind (value_ptradd (valp, -1));
+ val = ada_value_struct_elt (tsd, "expanded_name", 1);
if (val == NULL)
- return 0;
- val = ada_value_struct_elt (val, "expanded_name", 1);
- if (val == NULL)
- return 0;
+ return NULL;
read_memory_string (value_as_address (val), name, sizeof (name) - 1);
for (p = name; *p != '\0'; p += 1)
if (isalpha (*p))
*p = tolower (*p);
- args->name = name;
- return 0;
+ return name;
}
/* The type name of the dynamic type denoted by the 'tag value TAG, as
- a C string. */
+ a C string.
+
+ Return NULL if the TAG is not an Ada tag, or if we were unable to
+ determine the name of that tag. The result is good until the next
+ call. */
const char *
ada_tag_name (struct value *tag)
{
- struct tag_args args;
+ volatile struct gdb_exception e;
+ char *name = NULL;
if (!ada_is_tag_type (value_type (tag)))
return NULL;
- args.tag = tag;
- args.name = NULL;
- catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
- return args.name;
+
+ /* It is perfectly possible that an exception be raised while trying
+ to determine the TAG's name, even under normal circumstances:
+ The associated variable may be uninitialized or corrupted, for
+ instance. We do not let any exception propagate past this point.
+ instead we return NULL.
+
+ We also do not print the error message either (which often is very
+ low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
+ the caller print a more meaningful message if necessary. */
+ TRY_CATCH (e, RETURN_MASK_ERROR)
+ {
+ struct value *tsd = ada_get_tsd_from_tag (tag);
+
+ if (tsd != NULL)
+ name = ada_tag_name_from_tsd (tsd);
+ }
+
+ return name;
}
/* The parent type of TYPE, or NULL if none. */
struct value *
ada_value_ind (struct value *val0)
{
- struct value *val = unwrap_value (value_ind (val0));
+ struct value *val = value_ind (val0);
return ada_to_fixed_value (val);
}
struct value *val = val0;
val = coerce_ref (val);
- val = unwrap_value (val);
return ada_to_fixed_value (val);
}
else
return atoi (name + align_offset) * TARGET_CHAR_BIT;
}
-/* Find a symbol named NAME. Ignores ambiguity. */
+/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
-struct symbol *
-ada_find_any_symbol (const char *name)
+static struct symbol *
+ada_find_any_type_symbol (const char *name)
{
struct symbol *sym;
solely for types defined by debug info, it will not search the GDB
primitive types. */
-struct type *
+static struct type *
ada_find_any_type (const char *name)
{
- struct symbol *sym = ada_find_any_symbol (name);
+ struct symbol *sym = ada_find_any_type_symbol (name);
if (sym != NULL)
return SYMBOL_TYPE (sym);
return NULL;
}
-/* Given NAME and an associated BLOCK, search all symbols for
- NAME suffixed with "___XR", which is the ``renaming'' symbol
- associated to NAME. Return this symbol if found, return
- NULL otherwise. */
+/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
+ associated with NAME_SYM's name. NAME_SYM may itself be a renaming
+ symbol, in which case it is returned. Otherwise, this looks for
+ symbols whose name is that of NAME_SYM suffixed with "___XR".
+ Return symbol if found, and NULL otherwise. */
struct symbol *
-ada_find_renaming_symbol (const char *name, struct block *block)
+ada_find_renaming_symbol (struct symbol *name_sym, struct block *block)
{
+ const char *name = SYMBOL_LINKAGE_NAME (name_sym);
struct symbol *sym;
+ if (strstr (name, "___XR") != NULL)
+ return name_sym;
+
sym = find_old_style_renaming_symbol (name, block);
if (sym != NULL)
return sym;
/* Not right yet. FIXME pnh 7/20/2007. */
- sym = ada_find_any_symbol (name);
+ sym = ada_find_any_type_symbol (name);
if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
return sym;
else
xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
}
- return ada_find_any_symbol (rename);
+ return ada_find_any_type_symbol (rename);
}
/* Because of GNAT encoding conventions, several GDB symbols may match a
{
off = align_value (off, field_alignment (type, f))
+ TYPE_FIELD_BITPOS (type, f);
- TYPE_FIELD_BITPOS (rtype, f) = off;
+ SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
TYPE_FIELD_BITSIZE (rtype, f) = 0;
if (ada_is_variant_part (type, f))
}
else
{
- struct type *field_type = TYPE_FIELD_TYPE (type, f);
-
- /* If our field is a typedef type (most likely a typedef of
- a fat pointer, encoding an array access), then we need to
- look at its target type to determine its characteristics.
- In particular, we would miscompute the field size if we took
- the size of the typedef (zero), instead of the size of
- the target type. */
- if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
- field_type = ada_typedef_target_type (field_type);
-
- TYPE_FIELD_TYPE (rtype, f) = field_type;
+ /* Note: If this field's type is a typedef, it is important
+ to preserve the typedef layer.
+
+ Otherwise, we might be transforming a typedef to a fat
+ pointer (encoding a pointer to an unconstrained array),
+ into a basic fat pointer (encoding an unconstrained
+ array). As both types are implemented using the same
+ structure, the typedef is the only clue which allows us
+ to distinguish between the two options. Stripping it
+ would prevent us from printing this field appropriately. */
+ TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
if (TYPE_FIELD_BITSIZE (type, f) > 0)
fld_bit_len =
TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
else
- fld_bit_len =
- TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
+ {
+ struct type *field_type = TYPE_FIELD_TYPE (type, f);
+
+ /* We need to be careful of typedefs when computing
+ the length of our field. If this is a typedef,
+ get the length of the target type, not the length
+ of the typedef. */
+ if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
+ field_type = ada_typedef_target_type (field_type);
+
+ fld_bit_len =
+ TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
+ }
}
if (off + fld_bit_len > bit_len)
bit_len = off + fld_bit_len;
error (_("array type with dynamic size is larger than varsize-limit"));
}
+ /* We want to preserve the type name. This can be useful when
+ trying to get the type name of a value that has already been
+ printed (for instance, if the user did "print VAR; whatis $". */
+ TYPE_NAME (result) = TYPE_NAME (type0);
+
if (constrained_packed_array_p)
{
/* So far, the resulting type has been created as if the original
struct value *
ada_to_fixed_value (struct value *val)
{
- return ada_to_fixed_value_create (value_type (val),
- value_address (val),
- val);
+ val = unwrap_value (val);
+ val = ada_to_fixed_value_create (value_type (val),
+ value_address (val),
+ val);
+ return val;
}
\f
for (i = 0; i < TYPE_NFIELDS (type); i += 1)
{
- if (v == TYPE_FIELD_BITPOS (type, i))
+ if (v == TYPE_FIELD_ENUMVAL (type, i))
return i;
}
error (_("enumeration value is invalid: can't find 'POS"));
if (pos < 0 || pos >= TYPE_NFIELDS (type))
error (_("argument to 'VAL out of range"));
- return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
+ return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
}
else
return value_from_longest (type, value_as_long (arg));
return value_from_double (type, val);
}
+/* Given two array types T1 and T2, return nonzero iff both arrays
+ contain the same number of elements. */
+
+static int
+ada_same_array_size_p (struct type *t1, struct type *t2)
+{
+ LONGEST lo1, hi1, lo2, hi2;
+
+ /* Get the array bounds in order to verify that the size of
+ the two arrays match. */
+ if (!get_array_bounds (t1, &lo1, &hi1)
+ || !get_array_bounds (t2, &lo2, &hi2))
+ error (_("unable to determine array bounds"));
+
+ /* To make things easier for size comparison, normalize a bit
+ the case of empty arrays by making sure that the difference
+ between upper bound and lower bound is always -1. */
+ if (lo1 > hi1)
+ hi1 = lo1 - 1;
+ if (lo2 > hi2)
+ hi2 = lo2 - 1;
+
+ return (hi1 - lo1 == hi2 - lo2);
+}
+
+/* Assuming that VAL is an array of integrals, and TYPE represents
+ an array with the same number of elements, but with wider integral
+ elements, return an array "casted" to TYPE. In practice, this
+ means that the returned array is built by casting each element
+ of the original array into TYPE's (wider) element type. */
+
+static struct value *
+ada_promote_array_of_integrals (struct type *type, struct value *val)
+{
+ struct type *elt_type = TYPE_TARGET_TYPE (type);
+ LONGEST lo, hi;
+ struct value *res;
+ LONGEST i;
+
+ /* Verify that both val and type are arrays of scalars, and
+ that the size of val's elements is smaller than the size
+ of type's element. */
+ gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
+ gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
+ gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
+ gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
+ gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
+ > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
+
+ if (!get_array_bounds (type, &lo, &hi))
+ error (_("unable to determine array bounds"));
+
+ res = allocate_value (type);
+
+ /* Promote each array element. */
+ for (i = 0; i < hi - lo + 1; i++)
+ {
+ struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
+
+ memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
+ value_contents_all (elt), TYPE_LENGTH (elt_type));
+ }
+
+ return res;
+}
+
/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
return the converted value. */
if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
&& TYPE_CODE (type) == TYPE_CODE_ARRAY)
{
- if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
- || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
- != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
+ if (!ada_same_array_size_p (type, type2))
+ error (_("cannot assign arrays of different length"));
+
+ if (is_integral_type (TYPE_TARGET_TYPE (type))
+ && is_integral_type (TYPE_TARGET_TYPE (type2))
+ && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
+ < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
+ {
+ /* Allow implicit promotion of the array elements to
+ a wider type. */
+ return ada_promote_array_of_integrals (type, val);
+ }
+
+ if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
+ != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
error (_("Incompatible types in assignment"));
deprecated_set_value_type (val, type);
}
else
{
elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
- elt = ada_to_fixed_value (unwrap_value (elt));
+ elt = ada_to_fixed_value (elt);
}
if (exp->elts[*pos].opcode == OP_AGGREGATE)
else
{
arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
- arg1 = unwrap_value (arg1);
return ada_to_fixed_value (arg1);
}
{
case TYPE_CODE_FUNC:
if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return allocate_value (TYPE_TARGET_TYPE (type));
+ {
+ struct type *rtype = TYPE_TARGET_TYPE (type);
+
+ if (TYPE_GNU_IFUNC (type))
+ return allocate_value (TYPE_TARGET_TYPE (rtype));
+ return allocate_value (rtype);
+ }
return call_function_by_hand (argvec[0], nargs, argvec + 1);
+ case TYPE_CODE_INTERNAL_FUNCTION:
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ /* We don't know anything about what the internal
+ function might return, but we have to return
+ something. */
+ return value_zero (builtin_type (exp->gdbarch)->builtin_int,
+ not_lval);
+ else
+ return call_internal_function (exp->gdbarch, exp->language_defn,
+ argvec[0], nargs, argvec + 1);
+
case TYPE_CODE_STRUCT:
{
int arity;
&& TYPE_UNSIGNED (subranged_type));
}
-/* Try to determine the lower and upper bounds of the given modular type
- using the type name only. Return non-zero and set L and U as the lower
- and upper bounds (respectively) if successful. */
-
-int
-ada_modulus_from_name (struct type *type, ULONGEST *modulus)
-{
- const char *name = ada_type_name (type);
- const char *suffix;
- int k;
- LONGEST U;
-
- if (name == NULL)
- return 0;
-
- /* Discrete type bounds are encoded using an __XD suffix. In our case,
- we are looking for static bounds, which means an __XDLU suffix.
- Moreover, we know that the lower bound of modular types is always
- zero, so the actual suffix should start with "__XDLU_0__", and
- then be followed by the upper bound value. */
- suffix = strstr (name, "__XDLU_0__");
- if (suffix == NULL)
- return 0;
- k = 10;
- if (!ada_scan_number (suffix, k, &U, NULL))
- return 0;
-
- *modulus = (ULONGEST) U + 1;
- return 1;
-}
-
/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
ULONGEST
ada_exception_support_info_sniffer (void)
{
struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
- struct symbol *sym;
/* If the exception info is already known, then no need to recompute it. */
if (data->exception_info != NULL)
for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
{
re_comp (known_runtime_file_name_patterns[i]);
- if (re_exec (sal.symtab->filename))
+ if (re_exec (lbasename (sal.symtab->filename)))
return 1;
if (sal.symtab->objfile != NULL
&& re_exec (sal.symtab->objfile->name))
s = cond_string;
TRY_CATCH (e, RETURN_MASK_ERROR)
{
- exp = parse_exp_1 (&s, block_for_pc (bl->address), 0);
+ exp = parse_exp_1 (&s, bl->address,
+ block_for_pc (bl->address), 0);
}
if (e.reason < 0)
warning (_("failed to reevaluate internal exception condition "
if (exp->elts[*pos].opcode == OP_TYPE)
{
if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
- LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
+ LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
+ &type_print_raw_options);
*pos += 3;
}
else
/* XXX: sprint_subexp */
print_subexp (exp, pos, stream, PREC_SUFFIX);
fputs_filtered (" in ", stream);
- LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
+ LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
+ &type_print_raw_options);
return;
case OP_DISCRETE_RANGE:
return compare_names;
}
+/* Implement the "la_read_var_value" language_defn method for Ada. */
+
+static struct value *
+ada_read_var_value (struct symbol *var, struct frame_info *frame)
+{
+ struct block *frame_block = NULL;
+ struct symbol *renaming_sym = NULL;
+
+ /* The only case where default_read_var_value is not sufficient
+ is when VAR is a renaming... */
+ if (frame)
+ frame_block = get_frame_block (frame, NULL);
+ if (frame_block)
+ renaming_sym = ada_find_renaming_symbol (var, frame_block);
+ if (renaming_sym != NULL)
+ return ada_read_renaming_var_value (renaming_sym, frame_block);
+
+ /* This is a typical case where we expect the default_read_var_value
+ function to work. */
+ return default_read_var_value (var, frame);
+}
+
const struct language_defn ada_language_defn = {
"ada", /* Language name */
language_ada,
range_check_off,
- type_check_off,
case_sensitive_on, /* Yes, Ada is case-insensitive, but
that's not quite what this means. */
array_row_major,
ada_print_typedef, /* Print a typedef using appropriate syntax */
ada_val_print, /* Print a value using appropriate syntax */
ada_value_print, /* Print a top-level value */
+ ada_read_var_value, /* la_read_var_value */
NULL, /* Language specific skip_trampoline */
NULL, /* name_of_this */
ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
/* Setup per-inferior data. */
observer_attach_inferior_exit (ada_inferior_exit);
ada_inferior_data
- = register_inferior_data_with_cleanup (ada_inferior_data_cleanup);
+ = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
}