#include "valprint.h"
#include "source.h"
#include "observer.h"
-
-#ifndef ADA_RETAIN_DOTS
-#define ADA_RETAIN_DOTS 0
-#endif
+#include "vec.h"
/* Define whether or not the C operator '/' truncates towards zero for
differently signed operands (truncation direction is undefined in C).
#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
#endif
-
static void extract_string (CORE_ADDR addr, char *buf);
static void modify_general_field (char *, LONGEST, int, int);
static void ada_add_block_symbols (struct obstack *,
struct block *, const char *,
- domain_enum, struct objfile *,
- struct symtab *, int);
+ domain_enum, struct objfile *, int);
static int is_nonfunction (struct ada_symbol_info *, int);
static void add_defn_to_vec (struct obstack *, struct symbol *,
- struct block *, struct symtab *);
+ struct block *);
static int num_defns_collected (struct obstack *);
struct objfile *);
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 LONGEST pos_atr (struct value *);
-static struct value *value_pos_atr (struct value *);
+static struct value *value_pos_atr (struct type *, struct value *);
static struct value *value_val_atr (struct type *, struct value *);
/* Utilities */
+/* 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 = 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 '>'.
+ The result is good until the next call. */
+
+static char *
+add_angle_brackets (const char *str)
+{
+ static char *result = NULL;
+
+ xfree (result);
+ result = (char *) xmalloc ((strlen (str) + 3) * sizeof (char));
+
+ sprintf (result, "<%s>", str);
+ return result;
+}
static char *
ada_get_gdb_completer_word_break_characters (void)
static void
ada_print_array_index (struct value *index_value, struct ui_file *stream,
- int format, enum val_prettyprint pretty)
+ const struct value_print_options *options)
{
- LA_VALUE_PRINT (index_value, stream, format, pretty);
+ LA_VALUE_PRINT (index_value, stream, options);
fprintf_filtered (stream, " => ");
}
return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
}
-/* Create a value of type TYPE whose contents come from VALADDR, if it
- is non-null, and whose memory address (in the inferior) is
- ADDRESS. */
-
-struct value *
-value_from_contents_and_address (struct type *type,
- const gdb_byte *valaddr,
- CORE_ADDR address)
-{
- struct value *v = allocate_value (type);
- if (valaddr == NULL)
- set_value_lazy (v, 1);
- else
- memcpy (value_contents_raw (v), valaddr, TYPE_LENGTH (type));
- VALUE_ADDRESS (v) = address;
- if (address != 0)
- VALUE_LVAL (v) = lval_memory;
- return v;
-}
-
/* The contents of value VAL, treated as a value of type TYPE. The
result is an lval in memory if VAL is. */
check_size (type);
result = allocate_value (type);
- VALUE_LVAL (result) = VALUE_LVAL (val);
+ set_value_component_location (result, val);
set_value_bitsize (result, value_bitsize (val));
set_value_bitpos (result, value_bitpos (val));
- VALUE_ADDRESS (result) = VALUE_ADDRESS (val) + value_offset (val);
+ VALUE_ADDRESS (result) += value_offset (val);
if (value_lazy (val)
|| TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
set_value_lazy (result, 1);
}
/* The largest value in the domain of TYPE, a discrete type, as an integer. */
-static struct value *
+static LONGEST
discrete_type_high_bound (struct type *type)
{
switch (TYPE_CODE (type))
{
case TYPE_CODE_RANGE:
- return value_from_longest (TYPE_TARGET_TYPE (type),
- TYPE_HIGH_BOUND (type));
+ return TYPE_HIGH_BOUND (type);
case TYPE_CODE_ENUM:
- return
- value_from_longest (type,
- TYPE_FIELD_BITPOS (type,
- TYPE_NFIELDS (type) - 1));
+ return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
+ case TYPE_CODE_BOOL:
+ return 1;
+ case TYPE_CODE_CHAR:
case TYPE_CODE_INT:
- return value_from_longest (type, max_of_type (type));
+ return max_of_type (type);
default:
error (_("Unexpected type in discrete_type_high_bound."));
}
}
/* The largest value in the domain of TYPE, a discrete type, as an integer. */
-static struct value *
+static LONGEST
discrete_type_low_bound (struct type *type)
{
switch (TYPE_CODE (type))
{
case TYPE_CODE_RANGE:
- return value_from_longest (TYPE_TARGET_TYPE (type),
- TYPE_LOW_BOUND (type));
+ return TYPE_LOW_BOUND (type);
case TYPE_CODE_ENUM:
- return value_from_longest (type, TYPE_FIELD_BITPOS (type, 0));
+ return TYPE_FIELD_BITPOS (type, 0);
+ case TYPE_CODE_BOOL:
+ return 0;
+ case TYPE_CODE_CHAR:
case TYPE_CODE_INT:
- return value_from_longest (type, min_of_type (type));
+ return min_of_type (type);
default:
error (_("Unexpected type in discrete_type_low_bound."));
}
k = 0;
for (p = decoded; *p != '\0'; p += 1)
{
- if (!ADA_RETAIN_DOTS && *p == '.')
+ if (*p == '.')
{
encoding_buffer[k] = encoding_buffer[k + 1] = '_';
k += 2;
return (isdigit (c) || (isalpha (c) && islower (c)));
}
-/* Decode:
- . Discard trailing .{DIGIT}+, ${DIGIT}+ or ___{DIGIT}+
- These are suffixes introduced by GNAT5 to nested subprogram
- names, and do not serve any purpose for the debugger.
- . Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
- . Discard final N if it follows a lowercase alphanumeric character
- (protected object subprogram suffix)
- . Convert other instances of embedded "__" to `.'.
- . Discard leading _ada_.
- . Convert operator names to the appropriate quoted symbols.
- . Remove everything after first ___ if it is followed by
- 'X'.
- . Replace TK__ with __, and a trailing B or TKB with nothing.
- . Replace _[EB]{DIGIT}+[sb] with nothing (protected object entries)
- . Put symbols that should be suppressed in <...> brackets.
- . Remove trailing X[bn]* suffix (indicating names in package bodies).
+/* Remove 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 && strncmp (encoded + i - 2, "___", 3) == 0)
+ *len = i - 2;
+ else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
+ *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 follows the GNAT entity encoding conventions, then return
+ the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
+ replaced by ENCODED.
The resulting string is valid until the next call of ada_decode.
- If the string is unchanged by demangling, the original string pointer
+ If the string is unchanged by decoding, the original string pointer
is returned. */
const char *
static char *decoding_buffer = NULL;
static size_t decoding_buffer_size = 0;
+ /* 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 (strncmp (encoded, "_ada_", 5) == 0)
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;
- /* Remove trailing .{DIGIT}+ or ___{DIGIT}+ or __{DIGIT}+. */
len0 = strlen (encoded);
- if (len0 > 1 && isdigit (encoded[len0 - 1]))
- {
- i = len0 - 2;
- while (i > 0 && isdigit (encoded[i]))
- i--;
- if (i >= 0 && encoded[i] == '.')
- len0 = i;
- else if (i >= 0 && encoded[i] == '$')
- len0 = i;
- else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
- len0 = i - 2;
- else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
- len0 = i - 1;
- }
-
- /* 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 (len0 > 1
- && encoded[len0 - 1] == 'N'
- && (isdigit (encoded[len0 - 2]) || islower (encoded[len0 - 2])))
- 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
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 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
len0 -= 3;
+ /* Remove trailing "B" suffixes. */
+ /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
+
if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
len0 -= 1;
/* Make decoded big enough for possible expansion by operator name. */
+
GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
decoded = decoding_buffer;
+ /* Remove trailing __{digit}+ or trailing ${digit}+. */
+
if (len0 > 1 && isdigit (encoded[len0 - 1]))
{
i = len0 - 2;
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;
if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
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
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 (!ADA_RETAIN_DOTS
- && i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
+ else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
{
+ /* Replace '__' by '.'. */
decoded[j] = '.';
at_start_name = 1;
i += 2;
}
else
{
+ /* It's a character part of the decoded name, so just copy it
+ over. */
decoded[j] = encoded[i];
i += 1;
j += 1;
}
decoded[j] = '\000';
+ /* Decoded names should never contain any uppercase character.
+ Double-check this, and abort the decoding if we find one. */
+
for (i = 0; decoded[i] != '\0'; i += 1)
if (isupper (decoded[i]) || decoded[i] == ' ')
goto Suppress;
if (*resultp == NULL)
{
const char *decoded = ada_decode (gsymbol->name);
- if (gsymbol->bfd_section != NULL)
+ if (gsymbol->obj_section != NULL)
{
- bfd *obfd = gsymbol->bfd_section->owner;
- if (obfd != NULL)
- {
- struct objfile *objf;
- ALL_OBJFILES (objf)
- {
- if (obfd == objf->obfd)
- {
- *resultp = obsavestring (decoded, strlen (decoded),
- &objf->objfile_obstack);
- break;
- }
- }
- }
+ struct objfile *objf = gsymbol->obj_section->objfile;
+ *resultp = obsavestring (decoded, strlen (decoded),
+ &objf->objfile_obstack);
}
/* Sometimes, we can't find a corresponding objfile, in which
case, we put the result on the heap. Since we only decode
ada_coerce_to_simple_array_type (struct type *type)
{
struct value *mark = value_mark ();
- struct value *dummy = value_from_longest (builtin_type_long, 0);
+ struct value *dummy = value_from_longest (builtin_type_int32, 0);
struct type *result;
deprecated_set_value_type (dummy, type);
result = ada_type_of_array (dummy, 0);
new_type = alloc_type (TYPE_OBJFILE (type));
new_elt_type = packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
elt_bits);
- create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0));
+ create_array_type (new_type, new_elt_type, TYPE_INDEX_TYPE (type));
TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
TYPE_NAME (new_type) = ada_type_name (type);
- if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0),
+ if (get_discrete_bounds (TYPE_INDEX_TYPE (type),
&low_bound, &high_bound) < 0)
low_bound = high_bound = 0;
if (high_bound < low_bound)
(*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
}
- TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE;
+ TYPE_FIXED_INSTANCE (new_type) = 1;
return new_type;
}
{
struct symbol *sym;
struct block **blocks;
- const char *raw_name = ada_type_name (ada_check_typedef (type));
- char *name = (char *) alloca (strlen (raw_name) + 1);
- char *tail = strstr (raw_name, "___XP");
+ char *raw_name = ada_type_name (ada_check_typedef (type));
+ char *name;
+ char *tail;
struct type *shadow_type;
long bits;
int i, n;
+ 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);
return NULL;
}
- if (BITS_BIG_ENDIAN && ada_is_modular_type (value_type (arr)))
+ if (gdbarch_bits_big_endian (current_gdbarch)
+ && 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
lowerbound = upperbound = 0;
}
- idx = value_as_long (value_pos_atr (ind[i]));
+ 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);
int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
/* Transmit bytes from least to most significant; delta is the direction
the indices move. */
- int delta = BITS_BIG_ENDIAN ? -1 : 1;
+ int delta = gdbarch_bits_big_endian (current_gdbarch) ? -1 : 1;
type = ada_check_typedef (type);
v = allocate_value (type);
bytes = (unsigned char *) (valaddr + offset);
}
- else if (value_lazy (obj))
+ else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
{
v = value_at (type,
VALUE_ADDRESS (obj) + value_offset (obj) + offset);
if (obj != NULL)
{
- VALUE_LVAL (v) = VALUE_LVAL (obj);
- if (VALUE_LVAL (obj) == lval_internalvar)
- VALUE_LVAL (v) = lval_internalvar_component;
- VALUE_ADDRESS (v) = VALUE_ADDRESS (obj) + value_offset (obj) + offset;
+ set_value_component_location (v, obj);
+ VALUE_ADDRESS (v) += value_offset (obj) + offset;
set_value_bitpos (v, bit_offset + value_bitpos (obj));
set_value_bitsize (v, bit_size);
if (value_bitpos (v) >= HOST_CHAR_BIT)
memset (unpacked, 0, TYPE_LENGTH (type));
return v;
}
- else if (BITS_BIG_ENDIAN)
+ else if (gdbarch_bits_big_endian (current_gdbarch))
{
src = len - 1;
if (has_negatives (type)
targ_offset %= HOST_CHAR_BIT;
source += src_offset / HOST_CHAR_BIT;
src_offset %= HOST_CHAR_BIT;
- if (BITS_BIG_ENDIAN)
+ if (gdbarch_bits_big_endian (current_gdbarch))
{
accum = (unsigned char) *source;
source += 1;
{
int len = (value_bitpos (toval)
+ bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
+ int from_size;
char *buffer = (char *) alloca (len);
struct value *val;
CORE_ADDR to_addr = VALUE_ADDRESS (toval) + value_offset (toval);
fromval = value_cast (type, fromval);
read_memory (to_addr, buffer, len);
- if (BITS_BIG_ENDIAN)
+ from_size = value_bitsize (fromval);
+ if (from_size == 0)
+ from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
+ if (gdbarch_bits_big_endian (current_gdbarch))
move_bits (buffer, value_bitpos (toval),
- value_contents (fromval),
- TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT -
- bits, bits);
+ value_contents (fromval), from_size - bits, bits);
else
move_bits (buffer, value_bitpos (toval), value_contents (fromval),
0, bits);
else
bits = value_bitsize (component);
- if (BITS_BIG_ENDIAN)
+ if (gdbarch_bits_big_endian (current_gdbarch))
move_bits (value_contents_writeable (container) + offset_in_container,
value_bitpos (container) + bit_offset_in_container,
value_contents (val),
{
if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
error (_("too many subscripts (%d expected)"), k);
- elt = value_subscript (elt, value_pos_atr (ind[k]));
+ elt = value_subscript (elt, value_pos_atr (builtin_type_int32, ind[k]));
}
return elt;
}
arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
value_copy (arr));
get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
- idx = value_pos_atr (ind[k]);
+ idx = value_pos_atr (builtin_type_int32, ind[k]);
if (lwb != 0)
- idx = value_sub (idx, value_from_longest (builtin_type_int, lwb));
- arr = value_add (arr, idx);
+ idx = value_binop (idx, value_from_longest (value_type (idx), lwb),
+ BINOP_SUB);
+
+ arr = value_ptradd (arr, idx);
type = TYPE_TARGET_TYPE (type);
}
}
/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
- actual type of ARRAY_PTR is ignored), returns a reference to
- the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
- bound of this array is LOW, as per Ada rules. */
+ actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
+ elements starting at index LOW. The lower bound of this array is LOW, as
+ per Ada rules. */
static struct value *
-ada_value_slice_ptr (struct value *array_ptr, struct type *type,
- int low, int high)
+ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
+ int low, int high)
{
CORE_ADDR base = value_as_address (array_ptr)
+ ((low - TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type)))
low, high);
struct type *slice_type =
create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
- return value_from_pointer (lookup_reference_type (slice_type), base);
+ return value_at_lazy (slice_type, base);
}
for (i = 1; i < n; i += 1)
type = TYPE_TARGET_TYPE (type);
- result_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
+ result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (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 == NULL || TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
- result_type = builtin_type_int;
+ result_type = builtin_type_int32;
return result_type;
}
bounds type. It works for other arrays with bounds supplied by
run-time quantities other than discriminants. */
-LONGEST
+static LONGEST
ada_array_bound_from_type (struct type * arr_type, int n, int which,
struct type ** typep)
{
- struct type *type;
- struct type *index_type_desc;
+ struct type *type, *index_type_desc, *index_type;
+ LONGEST retval;
+
+ gdb_assert (which == 0 || which == 1);
if (ada_is_packed_array_type (arr_type))
arr_type = decode_packed_array_type (arr_type);
if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
{
if (typep != NULL)
- *typep = builtin_type_int;
+ *typep = builtin_type_int32;
return (LONGEST) - which;
}
type = arr_type;
index_type_desc = ada_find_parallel_type (type, "___XA");
- if (index_type_desc == NULL)
+ if (index_type_desc != NULL)
+ index_type = to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
+ NULL, TYPE_OBJFILE (arr_type));
+ else
{
- struct type *range_type;
- struct type *index_type;
-
while (n > 1)
{
type = TYPE_TARGET_TYPE (type);
n -= 1;
}
- range_type = TYPE_INDEX_TYPE (type);
- index_type = TYPE_TARGET_TYPE (range_type);
- if (TYPE_CODE (index_type) == TYPE_CODE_UNDEF)
- index_type = builtin_type_long;
- if (typep != NULL)
- *typep = index_type;
- return
- (LONGEST) (which == 0
- ? TYPE_LOW_BOUND (range_type)
- : TYPE_HIGH_BOUND (range_type));
+ index_type = TYPE_INDEX_TYPE (type);
}
- else
+
+ switch (TYPE_CODE (index_type))
{
- struct type *index_type =
- to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
- NULL, TYPE_OBJFILE (arr_type));
- if (typep != NULL)
- *typep = TYPE_TARGET_TYPE (index_type);
- return
- (LONGEST) (which == 0
- ? TYPE_LOW_BOUND (index_type)
- : TYPE_HIGH_BOUND (index_type));
+ case TYPE_CODE_RANGE:
+ retval = which == 0 ? TYPE_LOW_BOUND (index_type)
+ : TYPE_HIGH_BOUND (index_type);
+ break;
+ case TYPE_CODE_ENUM:
+ retval = which == 0 ? TYPE_FIELD_BITPOS (index_type, 0)
+ : TYPE_FIELD_BITPOS (index_type,
+ TYPE_NFIELDS (index_type) - 1);
+ break;
+ default:
+ internal_error (__FILE__, __LINE__, _("invalid type code of index type"));
}
+
+ if (typep != NULL)
+ *typep = index_type;
+
+ return retval;
}
/* 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
+ 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. */
struct value *
}
else
return
- value_from_longest (builtin_type_int,
+ value_from_longest (builtin_type_int32,
value_as_long (desc_one_bound (desc_bounds (arr),
n, 1))
- value_as_long (desc_one_bound (desc_bounds (arr),
case LOC_REGISTER:
case LOC_ARG:
case LOC_REF_ARG:
- case LOC_REGPARM:
case LOC_REGPARM_ADDR:
case LOC_LOCAL:
- case LOC_LOCAL_ARG:
- case LOC_BASEREG:
- case LOC_BASEREG_ARG:
case LOC_COMPUTED:
- case LOC_COMPUTED_ARG:
goto FoundNonType;
default:
break;
break;
case OP_TYPE:
+ case OP_REGISTER:
return NULL;
}
int *chosen = (int *) alloca (sizeof (int) * nsyms);
int n_chosen;
int first_choice = (max_results == 1) ? 1 : 2;
+ const char *select_mode = multiple_symbols_select_mode ();
if (max_results < 1)
error (_("Request to select 0 symbols!"));
if (nsyms <= 1)
return nsyms;
+ if (select_mode == multiple_symbols_cancel)
+ error (_("\
+canceled because the command is ambiguous\n\
+See set/show multiple-symbol."));
+
+ /* If select_mode is "all", then return all possible symbols.
+ Only do that if more than one symbol can be selected, of course.
+ Otherwise, display the menu as usual. */
+ if (select_mode == multiple_symbols_all && max_results > 1)
+ return nsyms;
+
printf_unfiltered (_("[0] cancel\n"));
if (max_results > 1)
printf_unfiltered (_("[1] all\n"));
int is_all_choice, char *annotation_suffix)
{
char *args;
- const char *prompt;
+ char *prompt;
int n_chosen;
int first_choice = is_all_choice ? 2 : 1;
prompt = getenv ("PS2");
if (prompt == NULL)
- prompt = ">";
-
- printf_unfiltered (("%s "), prompt);
- gdb_flush (gdb_stdout);
+ prompt = "> ";
- args = command_line_input ((char *) NULL, 0, annotation_suffix);
+ args = command_line_input (prompt, 0, annotation_suffix);
if (args == NULL)
error_no_arg (_("one or more choice numbers"));
if (gdbarch_frame_align_p (current_gdbarch))
*sp = gdbarch_frame_align (current_gdbarch, *sp);
}
+ VALUE_LVAL (val) = lval_memory;
write_memory (VALUE_ADDRESS (val), value_contents_raw (val), len);
}
allocating any necessary descriptors (fat pointers), or copies of
values not residing in memory, updating it as needed. */
-static struct value *
-convert_actual (struct value *actual, struct type *formal_type0,
- CORE_ADDR *sp)
+struct value *
+ada_convert_actual (struct value *actual, struct type *formal_type0,
+ CORE_ADDR *sp)
{
struct type *actual_type = ada_check_typedef (value_type (actual));
struct type *formal_type = ada_check_typedef (formal_type0);
if (ada_is_array_descriptor_type (formal_target)
&& TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
return make_array_descriptor (formal_type, actual, sp);
- else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR)
+ else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
+ || TYPE_CODE (formal_type) == TYPE_CODE_REF)
{
+ struct value *result;
if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
&& ada_is_array_descriptor_type (actual_target))
- return desc_data (actual);
+ result = desc_data (actual);
else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
{
if (VALUE_LVAL (actual) != lval_memory)
TYPE_LENGTH (actual_type));
actual = ensure_lval (val, sp);
}
- return value_addr (actual);
+ result = value_addr (actual);
}
+ else
+ return actual;
+ return value_cast_pointers (formal_type, result);
}
else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
return ada_value_ind (actual);
else
return descriptor;
}
-
-
-/* Assuming a dummy frame has been established on the target, perform any
- conversions needed for calling function FUNC on the NARGS actual
- parameters in ARGS, other than standard C conversions. Does
- nothing if FUNC does not have Ada-style prototype data, or if NARGS
- does not match the number of arguments expected. Use *SP as a
- stack pointer for additional data that must be pushed, updating its
- value as needed. */
-
-void
-ada_convert_actuals (struct value *func, int nargs, struct value *args[],
- CORE_ADDR *sp)
-{
- int i;
-
- if (TYPE_NFIELDS (value_type (func)) == 0
- || nargs != TYPE_NFIELDS (value_type (func)))
- return;
-
- for (i = 0; i < nargs; i += 1)
- args[i] =
- convert_actual (args[i], TYPE_FIELD_TYPE (value_type (func), i), sp);
-}
\f
/* Dummy definitions for an experimental caching module that is not
* used in the public sources. */
static int
lookup_cached_symbol (const char *name, domain_enum namespace,
- struct symbol **sym, struct block **block,
- struct symtab **symtab)
+ struct symbol **sym, struct block **block)
{
return 0;
}
static void
cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
- struct block *block, struct symtab *symtab)
+ struct block *block)
{
}
\f
domain_enum domain)
{
struct symbol *sym;
- struct symtab *symtab;
- if (lookup_cached_symbol (name, domain, &sym, NULL, NULL))
+ if (lookup_cached_symbol (name, domain, &sym, NULL))
return sym;
- sym =
- lookup_symbol_in_language (name, block, domain, language_c, 0, &symtab);
- cache_symbol (name, domain, sym, block_found, symtab);
+ sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
+ cache_symbol (name, domain, sym, block_found);
return sym;
}
static void
add_defn_to_vec (struct obstack *obstackp,
struct symbol *sym,
- struct block *block, struct symtab *symtab)
+ struct block *block)
{
int i;
size_t tmp;
{
prevDefns[i].sym = sym;
prevDefns[i].block = block;
- prevDefns[i].symtab = symtab;
return;
}
}
info.sym = sym;
info.block = block;
- info.symtab = symtab;
obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
}
}
{
struct partial_symbol *psym = start[i];
- if (SYMBOL_DOMAIN (psym) == namespace
+ if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
+ SYMBOL_DOMAIN (psym), namespace)
&& wild_match (name, name_len, SYMBOL_LINKAGE_NAME (psym)))
return psym;
}
{
struct partial_symbol *psym = start[i];
- if (SYMBOL_DOMAIN (psym) == namespace)
+ if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
+ SYMBOL_DOMAIN (psym), namespace))
{
int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym), name_len);
{
struct partial_symbol *psym = start[i];
- if (SYMBOL_DOMAIN (psym) == namespace)
+ if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
+ SYMBOL_DOMAIN (psym), namespace))
{
int cmp;
case LOC_REGISTER:
case LOC_ARG:
case LOC_REF_ARG:
- case LOC_REGPARM:
case LOC_REGPARM_ADDR:
case LOC_LOCAL:
case LOC_TYPEDEF:
- case LOC_LOCAL_ARG:
- case LOC_BASEREG:
- case LOC_BASEREG_ARG:
case LOC_COMPUTED:
- case LOC_COMPUTED_ARG:
for (j = FIRST_LOCAL_BLOCK;
j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
{
i = 0;
while (i < nsyms)
{
- if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
+ int remove = 0;
+
+ /* If two symbols have the same name and one of them is a stub type,
+ the get rid of the stub. */
+
+ if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
+ && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
+ {
+ for (j = 0; j < nsyms; j++)
+ {
+ if (j != i
+ && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
+ && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
+ && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
+ SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
+ remove = 1;
+ }
+ }
+
+ /* Two symbols with the same name, same class and same address
+ should be identical. */
+
+ else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
&& SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
&& is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
{
&& SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
&& SYMBOL_VALUE_ADDRESS (syms[i].sym)
== SYMBOL_VALUE_ADDRESS (syms[j].sym))
- {
- int k;
- for (k = i + 1; k < nsyms; k += 1)
- syms[k - 1] = syms[k];
- nsyms -= 1;
- goto NextSymbol;
- }
+ remove = 1;
}
}
+
+ if (remove)
+ {
+ for (j = i + 1; j < nsyms; j += 1)
+ syms[j - 1] = syms[j];
+ nsyms -= 1;
+ }
+
i += 1;
- NextSymbol:
- ;
}
return nsyms;
}
if (current_block == NULL)
return nsyms;
- current_function = block_function (current_block);
+ current_function = block_linkage_function (current_block);
if (current_function == NULL)
return nsyms;
return nsyms;
}
+/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
+ whose name and domain match NAME and DOMAIN respectively.
+ 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).
+
+ 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 block_depth = 0;
+
+ while (block != NULL)
+ {
+ block_depth += 1;
+ ada_add_block_symbols (obstackp, block, name, domain, NULL, wild_match);
+
+ /* If we found a non-function match, assume that's the one. */
+ if (is_nonfunction (defns_collected (obstackp, 0),
+ num_defns_collected (obstackp)))
+ return;
+
+ block = BLOCK_SUPERBLOCK (block);
+ }
+
+ /* 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 to OBSTACKP all non-local symbols whose name and domain match
+ NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
+ symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
+
+static void
+ada_add_non_local_symbols (struct obstack *obstackp, const char *name,
+ domain_enum domain, int global,
+ int wild_match)
+{
+ struct objfile *objfile;
+ struct partial_symtab *ps;
+
+ ALL_PSYMTABS (objfile, ps)
+ {
+ QUIT;
+ if (ps->readin
+ || ada_lookup_partial_symbol (ps, name, global, domain, wild_match))
+ {
+ struct symtab *s = PSYMTAB_TO_SYMTAB (ps);
+ const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
+
+ if (s == NULL || !s->primary)
+ continue;
+ ada_add_block_symbols (obstackp,
+ BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), block_kind),
+ name, domain, objfile, wild_match);
+ }
+ }
+}
+
/* 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,SYMTAB) triples,
+ *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
struct ada_symbol_info **results)
{
struct symbol *sym;
- struct symtab *s;
- struct partial_symtab *ps;
- struct blockvector *bv;
- struct objfile *objfile;
struct block *block;
const char *name;
- struct minimal_symbol *msymbol;
int wild_match;
int cacheIfUnique;
- int block_depth;
int ndefns;
obstack_free (&symbol_list_obstack, NULL);
block = (struct block *) block0; /* FIXME: No cast ought to be
needed, but adding const will
have a cascade effect. */
+
+ /* Special case: If the user specifies a symbol name inside package
+ Standard, do a non-wild matching of the symbol name without
+ the "standard__" prefix. This was primarily introduced in order
+ to allow the user to specifically access the standard exceptions
+ using, for instance, Standard.Constraint_Error when Constraint_Error
+ is ambiguous (due to the user defining its own Constraint_Error
+ entity inside its program). */
if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
{
wild_match = 0;
name = name0 + sizeof ("standard__") - 1;
}
- block_depth = 0;
- while (block != NULL)
- {
- block_depth += 1;
- ada_add_block_symbols (&symbol_list_obstack, block, name,
- namespace, NULL, NULL, wild_match);
-
- /* If we found a non-function match, assume that's the one. */
- if (is_nonfunction (defns_collected (&symbol_list_obstack, 0),
- num_defns_collected (&symbol_list_obstack)))
- goto done;
-
- block = BLOCK_SUPERBLOCK (block);
- }
-
- /* If no luck so far, try to find NAME as a local symbol in some lexically
- enclosing subprogram. */
- if (num_defns_collected (&symbol_list_obstack) == 0 && block_depth > 2)
- add_symbols_from_enclosing_procs (&symbol_list_obstack,
- name, namespace, wild_match);
-
- /* If we found ANY matches among non-global symbols, we're done. */
+ /* 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);
if (num_defns_collected (&symbol_list_obstack) > 0)
goto done;
+ /* No non-global symbols found. Check our cache to see if we have
+ already performed this search before. If we have, then return
+ the same result. */
+
cacheIfUnique = 1;
- if (lookup_cached_symbol (name0, namespace, &sym, &block, &s))
+ if (lookup_cached_symbol (name0, namespace, &sym, &block))
{
if (sym != NULL)
- add_defn_to_vec (&symbol_list_obstack, sym, block, s);
+ add_defn_to_vec (&symbol_list_obstack, sym, block);
goto done;
}
- /* Now add symbols from all global blocks: symbol tables, minimal symbol
- tables, and psymtab's. */
-
- ALL_PRIMARY_SYMTABS (objfile, s)
- {
- QUIT;
- bv = BLOCKVECTOR (s);
- block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
- ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
- objfile, s, wild_match);
- }
-
- if (namespace == VAR_DOMAIN)
- {
- ALL_MSYMBOLS (objfile, msymbol)
- {
- if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match))
- {
- switch (MSYMBOL_TYPE (msymbol))
- {
- case mst_solib_trampoline:
- break;
- default:
- s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol));
- if (s != NULL)
- {
- int ndefns0 = num_defns_collected (&symbol_list_obstack);
- QUIT;
- bv = BLOCKVECTOR (s);
- block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
- ada_add_block_symbols (&symbol_list_obstack, block,
- SYMBOL_LINKAGE_NAME (msymbol),
- namespace, objfile, s, wild_match);
-
- if (num_defns_collected (&symbol_list_obstack) == ndefns0)
- {
- block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
- ada_add_block_symbols (&symbol_list_obstack, block,
- SYMBOL_LINKAGE_NAME (msymbol),
- namespace, objfile, s,
- wild_match);
- }
- }
- }
- }
- }
- }
-
- ALL_PSYMTABS (objfile, ps)
- {
- QUIT;
- if (!ps->readin
- && ada_lookup_partial_symbol (ps, name, 1, namespace, wild_match))
- {
- s = PSYMTAB_TO_SYMTAB (ps);
- if (!s->primary)
- continue;
- bv = BLOCKVECTOR (s);
- block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
- ada_add_block_symbols (&symbol_list_obstack, block, name,
- namespace, objfile, s, wild_match);
- }
- }
+ /* Search symbols from all global blocks. */
+
+ ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 1,
+ wild_match);
/* Now add symbols from all per-file blocks if we've gotten no hits
- (Not strictly correct, but perhaps better than an error).
- Do the symtabs first, then check the psymtabs. */
+ (not strictly correct, but perhaps better than an error). */
if (num_defns_collected (&symbol_list_obstack) == 0)
- {
-
- ALL_PRIMARY_SYMTABS (objfile, s)
- {
- QUIT;
- bv = BLOCKVECTOR (s);
- block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
- ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
- objfile, s, wild_match);
- }
-
- ALL_PSYMTABS (objfile, ps)
- {
- QUIT;
- if (!ps->readin
- && ada_lookup_partial_symbol (ps, name, 0, namespace, wild_match))
- {
- s = PSYMTAB_TO_SYMTAB (ps);
- bv = BLOCKVECTOR (s);
- if (!s->primary)
- continue;
- block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
- ada_add_block_symbols (&symbol_list_obstack, block, name,
- namespace, objfile, s, wild_match);
- }
- }
- }
+ ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 0,
+ wild_match);
done:
ndefns = num_defns_collected (&symbol_list_obstack);
ndefns = remove_extra_symbols (*results, ndefns);
if (ndefns == 0)
- cache_symbol (name0, namespace, NULL, NULL, NULL);
+ cache_symbol (name0, namespace, NULL, NULL);
if (ndefns == 1 && cacheIfUnique)
- cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block,
- (*results)[0].symtab);
+ 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, struct symtab **symtab)
+ domain_enum namespace, struct block **block_found)
{
struct ada_symbol_info *candidates;
int n_candidates;
if (block_found != NULL)
*block_found = candidates[0].block;
- if (symtab != NULL)
- {
- *symtab = candidates[0].symtab;
- if (*symtab == NULL && candidates[0].block != NULL)
- {
- struct objfile *objfile;
- struct symtab *s;
- struct block *b;
- struct blockvector *bv;
-
- /* Search the list of symtabs for one which contains the
- address of the start of this block. */
- ALL_PRIMARY_SYMTABS (objfile, s)
- {
- bv = BLOCKVECTOR (s);
- b = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
- if (BLOCK_START (b) <= BLOCK_START (candidates[0].block)
- && BLOCK_END (b) > BLOCK_START (candidates[0].block))
- {
- *symtab = s;
- return fixup_symbol_section (candidates[0].sym, objfile);
- }
- }
- /* FIXME: brobecker/2004-11-12: I think that we should never
- reach this point. I don't see a reason why we would not
- find a symtab for a given block, so I suggest raising an
- internal_error exception here. Otherwise, we end up
- returning a symbol but no symtab, which certain parts of
- the code that rely (indirectly) on this function do not
- expect, eventually causing a SEGV. */
- return fixup_symbol_section (candidates[0].sym, NULL);
- }
- }
- return candidates[0].sym;
+ return fixup_symbol_section (candidates[0].sym, NULL);
}
/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
assignments occur only if the pointers are non-null). */
struct symbol *
ada_lookup_symbol (const char *name, const struct block *block0,
- domain_enum namespace, int *is_a_field_of_this,
- struct symtab **symtab)
+ domain_enum namespace, int *is_a_field_of_this)
{
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, symtab);
+ block0, namespace, NULL);
}
static struct symbol *
ada_lookup_symbol_nonlocal (const char *name,
const char *linkage_name,
const struct block *block,
- const domain_enum domain, struct symtab **symtab)
+ const domain_enum domain)
{
if (linkage_name == NULL)
linkage_name = name;
return ada_lookup_symbol (linkage_name, block_static_block (block), domain,
- NULL, symtab);
+ NULL);
}
/* True iff STR is a possible encoded suffix of a normal Ada name
that is to be ignored for matching purposes. Suffixes of parallel
names (e.g., XVE) are not included here. Currently, the possible suffixes
- are given by either of the regular expression:
+ are given by any of the regular expressions:
- (__[0-9]+)?[.$][0-9]+ [nested subprogram suffix, on platforms such
- as GNU/Linux]
- ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
- _E[0-9]+[bs]$ [protected object entry suffixes]
+ [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
+ ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
+ _E[0-9]+[bs]$ [protected object entry suffixes]
(X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
- */
+
+ Also, any leading "__[0-9]+" sequence is skipped before the suffix
+ match is performed. This sequence is used to differentiate homonyms,
+ is an optional part of a valid name suffix. */
static int
is_name_suffix (const char *str)
const char *matching;
const int len = strlen (str);
- /* (__[0-9]+)?\.[0-9]+ */
- matching = str;
+ /* Skip optional leading __[0-9]+. */
+
if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
{
- matching += 3;
- while (isdigit (matching[0]))
- matching += 1;
- if (matching[0] == '\0')
- return 1;
+ str += 3;
+ while (isdigit (str[0]))
+ str += 1;
}
+
+ /* [.$][0-9]+ */
- if (matching[0] == '.' || matching[0] == '$')
+ if (str[0] == '.' || str[0] == '$')
{
- matching += 1;
+ matching = str + 1;
while (isdigit (matching[0]))
matching += 1;
if (matching[0] == '\0')
}
/* ___[0-9]+ */
+
if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
{
matching = str + 3;
str += 1;
}
}
+
if (str[0] == '\000')
return 1;
+
if (str[0] == '_')
{
if (str[1] != '_' || str[2] == '\000')
return 0;
}
-/* Return nonzero if the given string starts with a dot ('.')
- followed by zero or more digits.
-
- Note: brobecker/2003-11-10: A forward declaration has not been
- added at the begining of this file yet, because this function
- is only used to work around a problem found during wild matching
- when trying to match minimal symbol names against symbol names
- obtained from dwarf-2 data. This function is therefore currently
- only used in wild_match() and is likely to be deleted when the
- problem in dwarf-2 is fixed. */
-
-static int
-is_dot_digits_suffix (const char *str)
-{
- if (str[0] != '.')
- return 0;
-
- str++;
- while (isdigit (str[0]))
- str++;
- return (str[0] == '\0');
-}
-
/* Return non-zero if the string starting at NAME and ending before
NAME_END contains no capital letters. */
const char *decoded_name = ada_decode (name0);
int i;
+ /* If the decoded name starts with an angle bracket, it means that
+ NAME0 does not follow the GNAT encoding format. It should then
+ not be allowed as a possible wild match. */
+ if (decoded_name[0] == '<')
+ return 0;
+
for (i=0; decoded_name[i] != '\0'; i++)
if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
return 0;
static int
wild_match (const char *patn0, int patn_len, const char *name0)
{
- int name_len;
- char *name;
- char *name_start;
- char *patn;
-
- /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
- stored in the symbol table for nested function names is sometimes
- different from the name of the associated entity stored in
- the dwarf-2 data: This is the case for nested subprograms, where
- the minimal symbol name contains a trailing ".[:digit:]+" suffix,
- while the symbol name from the dwarf-2 data does not.
-
- Although the DWARF-2 standard documents that entity names stored
- in the dwarf-2 data should be identical to the name as seen in
- the source code, GNAT takes a different approach as we already use
- a special encoding mechanism to convey the information so that
- a C debugger can still use the information generated to debug
- Ada programs. A corollary is that the symbol names in the dwarf-2
- data should match the names found in the symbol table. I therefore
- consider this issue as a compiler defect.
-
- Until the compiler is properly fixed, we work-around the problem
- by ignoring such suffixes during the match. We do so by making
- a copy of PATN0 and NAME0, and then by stripping such a suffix
- if present. We then perform the match on the resulting strings. */
- {
- char *dot;
- name_len = strlen (name0);
-
- name = name_start = (char *) alloca ((name_len + 1) * sizeof (char));
- strcpy (name, name0);
- dot = strrchr (name, '.');
- if (dot != NULL && is_dot_digits_suffix (dot))
- *dot = '\0';
-
- patn = (char *) alloca ((patn_len + 1) * sizeof (char));
- strncpy (patn, patn0, patn_len);
- patn[patn_len] = '\0';
- dot = strrchr (patn, '.');
- if (dot != NULL && is_dot_digits_suffix (dot))
- {
- *dot = '\0';
- patn_len = dot - patn;
- }
- }
-
- /* Now perform the wild match. */
-
- name_len = strlen (name);
- if (name_len >= patn_len + 5 && strncmp (name, "_ada_", 5) == 0
- && strncmp (patn, name + 5, patn_len) == 0
- && is_name_suffix (name + patn_len + 5))
- return 1;
-
- while (name_len >= patn_len)
+ char* match;
+ const char* start;
+ start = name0;
+ while (1)
{
- if (strncmp (patn, name, patn_len) == 0
- && is_name_suffix (name + patn_len))
- return (name == name_start || is_valid_name_for_wild_match (name0));
- do
- {
- name += 1;
- name_len -= 1;
- }
- while (name_len > 0
- && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
- if (name_len <= 0)
- return 0;
- if (name[0] == '_')
- {
- if (!islower (name[2]))
- return 0;
- name += 2;
- name_len -= 2;
- }
- else
- {
- if (!islower (name[1]))
- return 0;
- name += 1;
- name_len -= 1;
- }
+ match = strstr (start, patn0);
+ if (match == NULL)
+ return 0;
+ if ((match == name0
+ || match[-1] == '.'
+ || (match > name0 + 1 && match[-1] == '_' && match[-2] == '_')
+ || (match == name0 + 5 && strncmp ("_ada_", name0, 5) == 0))
+ && is_name_suffix (match + patn_len))
+ return (match == name0 || is_valid_name_for_wild_match (name0));
+ start = match + 1;
}
-
- return 0;
}
ada_add_block_symbols (struct obstack *obstackp,
struct block *block, const char *name,
domain_enum domain, struct objfile *objfile,
- struct symtab *symtab, int wild)
+ int wild)
{
struct dict_iterator iter;
int name_len = strlen (name);
struct symbol *sym;
ALL_BLOCK_SYMBOLS (block, iter, sym)
{
- if (SYMBOL_DOMAIN (sym) == domain
- && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
- {
- switch (SYMBOL_CLASS (sym))
- {
- case LOC_ARG:
- case LOC_LOCAL_ARG:
- case LOC_REF_ARG:
- case LOC_REGPARM:
- case LOC_REGPARM_ADDR:
- case LOC_BASEREG_ARG:
- case LOC_COMPUTED_ARG:
- arg_sym = sym;
- break;
- case LOC_UNRESOLVED:
- continue;
- default:
- found_sym = 1;
- add_defn_to_vec (obstackp,
- fixup_symbol_section (sym, objfile),
- block, symtab);
- break;
- }
- }
+ if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
+ SYMBOL_DOMAIN (sym), domain)
+ && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
+ {
+ if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
+ continue;
+ else if (SYMBOL_IS_ARGUMENT (sym))
+ arg_sym = sym;
+ else
+ {
+ found_sym = 1;
+ add_defn_to_vec (obstackp,
+ fixup_symbol_section (sym, objfile),
+ block);
+ }
+ }
+ }
+ }
+ else
+ {
+ ALL_BLOCK_SYMBOLS (block, iter, sym)
+ {
+ if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
+ SYMBOL_DOMAIN (sym), domain))
+ {
+ int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
+ if (cmp == 0
+ && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
+ {
+ if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
+ {
+ if (SYMBOL_IS_ARGUMENT (sym))
+ arg_sym = sym;
+ else
+ {
+ found_sym = 1;
+ add_defn_to_vec (obstackp,
+ fixup_symbol_section (sym, objfile),
+ block);
+ }
+ }
+ }
+ }
+ }
+ }
+
+ if (!found_sym && arg_sym != NULL)
+ {
+ add_defn_to_vec (obstackp,
+ fixup_symbol_section (arg_sym, objfile),
+ block);
+ }
+
+ if (!wild)
+ {
+ arg_sym = NULL;
+ found_sym = 0;
+
+ ALL_BLOCK_SYMBOLS (block, iter, sym)
+ {
+ if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
+ SYMBOL_DOMAIN (sym), domain))
+ {
+ int cmp;
+
+ cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
+ if (cmp == 0)
+ {
+ cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
+ if (cmp == 0)
+ cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
+ name_len);
+ }
+
+ if (cmp == 0
+ && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
+ {
+ if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
+ {
+ if (SYMBOL_IS_ARGUMENT (sym))
+ arg_sym = sym;
+ else
+ {
+ found_sym = 1;
+ add_defn_to_vec (obstackp,
+ fixup_symbol_section (sym, objfile),
+ block);
+ }
+ }
+ }
+ }
+ }
+
+ /* NOTE: This really shouldn't be needed for _ada_ symbols.
+ They aren't parameters, right? */
+ if (!found_sym && arg_sym != NULL)
+ {
+ add_defn_to_vec (obstackp,
+ fixup_symbol_section (arg_sym, objfile),
+ block);
+ }
+ }
+}
+\f
+
+ /* Symbol Completion */
+
+/* If SYM_NAME is a completion candidate for TEXT, return this symbol
+ name in a form that's appropriate for the completion. The result
+ 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
+ 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)
+{
+ char *result;
+ const int verbatim_match = (text[0] == '<');
+ int match = 0;
+
+ if (verbatim_match)
+ {
+ /* Strip the leading angle bracket. */
+ text = text + 1;
+ text_len--;
+ }
+
+ /* First, test against the fully qualified name of the symbol. */
+
+ if (strncmp (sym_name, text, text_len) == 0)
+ match = 1;
+
+ if (match && !encoded)
+ {
+ /* One needed check before declaring a positive match is to verify
+ that iff we are doing a verbatim match, the decoded version
+ of the symbol name starts with '<'. Otherwise, this symbol name
+ is not a suitable completion. */
+ const char *sym_name_copy = sym_name;
+ int has_angle_bracket;
+
+ sym_name = ada_decode (sym_name);
+ has_angle_bracket = (sym_name[0] == '<');
+ match = (has_angle_bracket == verbatim_match);
+ sym_name = sym_name_copy;
+ }
+
+ if (match && !verbatim_match)
+ {
+ /* When doing non-verbatim match, another check that needs to
+ be done is to verify that the potentially matching symbol name
+ does not include capital letters, because the ada-mode would
+ not be able to understand these symbol names without the
+ angle bracket notation. */
+ const char *tmp;
+
+ for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
+ if (*tmp != '\0')
+ match = 0;
+ }
+
+ /* Second: Try wild matching... */
+
+ if (!match && wild_match)
+ {
+ /* Since we are doing wild matching, this means that TEXT
+ may represent an unqualified symbol name. We therefore must
+ also compare TEXT against the unqualified name of the symbol. */
+ sym_name = ada_unqualified_name (ada_decode (sym_name));
+
+ if (strncmp (sym_name, text, text_len) == 0)
+ match = 1;
+ }
+
+ /* Finally: If we found a mach, prepare the result to return. */
+
+ if (!match)
+ return NULL;
+
+ if (verbatim_match)
+ sym_name = add_angle_brackets (sym_name);
+
+ if (!encoded)
+ sym_name = ada_decode (sym_name);
+
+ return sym_name;
+}
+
+typedef char *char_ptr;
+DEF_VEC_P (char_ptr);
+
+/* A companion function to ada_make_symbol_completion_list().
+ Check if SYM_NAME represents a symbol which name would be suitable
+ to complete TEXT (TEXT_LEN is the length of TEXT), in which case
+ it is appended at the end of the given string vector SV.
+
+ ORIG_TEXT is the string original string from the user command
+ that needs to be completed. WORD is the entire command on which
+ 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
+ encoded formed (in which case the completion should also be
+ encoded). */
+
+static void
+symbol_completion_add (VEC(char_ptr) **sv,
+ const char *sym_name,
+ const char *text, int text_len,
+ const char *orig_text, const char *word,
+ int wild_match, int encoded)
+{
+ const char *match = symbol_completion_match (sym_name, text, text_len,
+ wild_match, encoded);
+ char *completion;
+
+ if (match == NULL)
+ return;
+
+ /* We found a match, so add the appropriate completion to the given
+ string vector. */
+
+ if (word == orig_text)
+ {
+ completion = xmalloc (strlen (match) + 5);
+ strcpy (completion, match);
+ }
+ else if (word > orig_text)
+ {
+ /* Return some portion of sym_name. */
+ completion = xmalloc (strlen (match) + 5);
+ strcpy (completion, match + (word - orig_text));
+ }
+ else
+ {
+ /* Return some of ORIG_TEXT plus sym_name. */
+ completion = xmalloc (strlen (match) + (orig_text - word) + 5);
+ strncpy (completion, word, orig_text - word);
+ completion[orig_text - word] = '\0';
+ strcat (completion, match);
+ }
+
+ VEC_safe_push (char_ptr, *sv, completion);
+}
+
+/* Return a list of possible symbol names completing TEXT0. The list
+ is NULL terminated. WORD is the entire command on which completion
+ is made. */
+
+static char **
+ada_make_symbol_completion_list (char *text0, char *word)
+{
+ char *text;
+ int text_len;
+ int wild_match;
+ int encoded;
+ VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
+ struct symbol *sym;
+ struct symtab *s;
+ struct partial_symtab *ps;
+ struct minimal_symbol *msymbol;
+ struct objfile *objfile;
+ struct block *b, *surrounding_static_block = 0;
+ int i;
+ struct dict_iterator iter;
+
+ if (text0[0] == '<')
+ {
+ text = xstrdup (text0);
+ make_cleanup (xfree, text);
+ text_len = strlen (text);
+ wild_match = 0;
+ encoded = 1;
+ }
+ else
+ {
+ text = xstrdup (ada_encode (text0));
+ make_cleanup (xfree, text);
+ text_len = strlen (text);
+ for (i = 0; i < text_len; i++)
+ text[i] = tolower (text[i]);
+
+ encoded = (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);
+ }
+
+ /* First, look at the partial symtab symbols. */
+ ALL_PSYMTABS (objfile, ps)
+ {
+ struct partial_symbol **psym;
+
+ /* If the psymtab's been read in we'll get it when we search
+ through the blockvector. */
+ if (ps->readin)
+ continue;
+
+ for (psym = objfile->global_psymbols.list + ps->globals_offset;
+ psym < (objfile->global_psymbols.list + ps->globals_offset
+ + ps->n_global_syms); psym++)
+ {
+ QUIT;
+ symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
+ text, text_len, text0, word,
+ wild_match, encoded);
+ }
+
+ for (psym = objfile->static_psymbols.list + ps->statics_offset;
+ psym < (objfile->static_psymbols.list + ps->statics_offset
+ + ps->n_static_syms); psym++)
+ {
+ QUIT;
+ symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
+ text, text_len, text0, word,
+ wild_match, encoded);
}
- }
- else
+ }
+
+ /* At this point scan through the misc symbol vectors and add each
+ symbol you find to the list. Eventually we want to ignore
+ anything that isn't a text symbol (everything else will be
+ handled by the psymtab code above). */
+
+ ALL_MSYMBOLS (objfile, msymbol)
+ {
+ QUIT;
+ symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
+ text, text_len, text0, word, wild_match, encoded);
+ }
+
+ /* Search upwards from currently selected frame (so that we can
+ complete on local vars. */
+
+ for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
{
- ALL_BLOCK_SYMBOLS (block, iter, sym)
+ if (!BLOCK_SUPERBLOCK (b))
+ surrounding_static_block = b; /* For elmin of dups */
+
+ ALL_BLOCK_SYMBOLS (b, iter, sym)
{
- if (SYMBOL_DOMAIN (sym) == domain)
- {
- int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
- if (cmp == 0
- && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
- {
- switch (SYMBOL_CLASS (sym))
- {
- case LOC_ARG:
- case LOC_LOCAL_ARG:
- case LOC_REF_ARG:
- case LOC_REGPARM:
- case LOC_REGPARM_ADDR:
- case LOC_BASEREG_ARG:
- case LOC_COMPUTED_ARG:
- arg_sym = sym;
- break;
- case LOC_UNRESOLVED:
- break;
- default:
- found_sym = 1;
- add_defn_to_vec (obstackp,
- fixup_symbol_section (sym, objfile),
- block, symtab);
- break;
- }
- }
- }
+ symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
+ text, text_len, text0, word,
+ wild_match, encoded);
}
}
- if (!found_sym && arg_sym != NULL)
+ /* Go through the symtabs and check the externs and statics for
+ symbols which match. */
+
+ ALL_SYMTABS (objfile, s)
+ {
+ QUIT;
+ b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
+ ALL_BLOCK_SYMBOLS (b, iter, sym)
{
- add_defn_to_vec (obstackp,
- fixup_symbol_section (arg_sym, objfile),
- block, symtab);
+ symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
+ text, text_len, text0, word,
+ wild_match, encoded);
}
+ }
- if (!wild)
+ ALL_SYMTABS (objfile, s)
+ {
+ QUIT;
+ b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
+ /* Don't do this block twice. */
+ if (b == surrounding_static_block)
+ continue;
+ ALL_BLOCK_SYMBOLS (b, iter, sym)
{
- arg_sym = NULL;
- found_sym = 0;
+ symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
+ text, text_len, text0, word,
+ wild_match, encoded);
+ }
+ }
- ALL_BLOCK_SYMBOLS (block, iter, sym)
- {
- if (SYMBOL_DOMAIN (sym) == domain)
- {
- int cmp;
+ /* Append the closing NULL entry. */
+ VEC_safe_push (char_ptr, completions, NULL);
- cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
- if (cmp == 0)
- {
- cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
- if (cmp == 0)
- cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
- name_len);
- }
+ /* 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 = malloc (completions_size);
+
+ memcpy (result, VEC_address (char_ptr, completions), completions_size);
+
+ VEC_free (char_ptr, completions);
+ return result;
+ }
+}
- if (cmp == 0
- && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
- {
- switch (SYMBOL_CLASS (sym))
- {
- case LOC_ARG:
- case LOC_LOCAL_ARG:
- case LOC_REF_ARG:
- case LOC_REGPARM:
- case LOC_REGPARM_ADDR:
- case LOC_BASEREG_ARG:
- case LOC_COMPUTED_ARG:
- arg_sym = sym;
- break;
- case LOC_UNRESOLVED:
- break;
- default:
- found_sym = 1;
- add_defn_to_vec (obstackp,
- fixup_symbol_section (sym, objfile),
- block, symtab);
- break;
- }
- }
- }
- }
+ /* Field Access */
- /* NOTE: This really shouldn't be needed for _ada_ symbols.
- They aren't parameters, right? */
- if (!found_sym && arg_sym != NULL)
- {
- add_defn_to_vec (obstackp,
- fixup_symbol_section (arg_sym, objfile),
- block, symtab);
- }
- }
+/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
+ for tagged types. */
+
+static int
+ada_is_dispatch_table_ptr_type (struct type *type)
+{
+ char *name;
+
+ if (TYPE_CODE (type) != TYPE_CODE_PTR)
+ return 0;
+
+ name = TYPE_NAME (TYPE_TARGET_TYPE (type));
+ if (name == NULL)
+ return 0;
+
+ return (strcmp (name, "ada__tags__dispatch_table") == 0);
}
-\f
- /* Field Access */
/* True if field number FIELD_NUM in struct or union type TYPE is supposed
to be invisible to users. */
{
if (field_num < 0 || field_num > TYPE_NFIELDS (type))
return 1;
- else
- {
- const char *name = TYPE_FIELD_NAME (type, field_num);
- return (name == NULL
- || (name[0] == '_' && strncmp (name, "_parent", 7) != 0));
- }
+
+ /* Check the name of that field. */
+ {
+ const char *name = TYPE_FIELD_NAME (type, field_num);
+
+ /* Anonymous field names should not be printed.
+ brobecker/2007-02-20: I don't think this can actually happen
+ but we don't want to print the value of annonymous fields anyway. */
+ if (name == NULL)
+ return 1;
+
+ /* A field named "_parent" is internally generated by GNAT for
+ tagged types, and should not be printed either. */
+ if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
+ return 1;
+ }
+
+ /* If this is the dispatch table of a tagged type, then ignore. */
+ if (ada_is_tagged_type (type, 1)
+ && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
+ return 1;
+
+ /* Not a special field, so it should not be ignored. */
+ return 0;
}
/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
valp = value_cast (info_type, args->tag);
if (valp == NULL)
return 0;
- val = value_ind (value_add (valp, value_from_longest (builtin_type_int, -1)));
+ val = value_ind (value_ptradd (valp,
+ value_from_longest (builtin_type_int8, -1)));
if (val == NULL)
return 0;
val = ada_value_struct_elt (val, "expanded_name", 1);
for (i = 0; i < TYPE_NFIELDS (type); i += 1)
if (ada_is_parent_field (type, i))
- return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
+ {
+ struct type *parent_type = TYPE_FIELD_TYPE (type, i);
+
+ /* If the _parent field is a pointer, then dereference it. */
+ if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
+ parent_type = TYPE_TARGET_TYPE (parent_type);
+ /* If there is a parallel XVS type, get the actual base type. */
+ parent_type = ada_get_base_type (parent_type);
+
+ return ada_check_typedef (parent_type);
+ }
return NULL;
}
struct type *type =
ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
if (type == NULL)
- return builtin_type_int;
+ return builtin_type_int32;
else
return type;
}
/* Given ARG, a value of type (pointer or reference to a)*
structure/union, extract the component named NAME from the ultimate
target structure/union and return it as a value with its
- appropriate type. If ARG is a pointer or reference and the field
- is not packed, returns a reference to the field, otherwise the
- value of the field (an lvalue if ARG is an lvalue).
+ appropriate type.
The routine searches for NAME among all members of the structure itself
and (recursively) among all members of any wrapper members
else
address = unpack_pointer (t, value_contents (arg));
- t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL);
+ t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
if (find_struct_field (name, t1, 0,
&field_type, &byte_offset, &bit_offset,
&bit_size, NULL))
field_type);
}
else
- v = value_from_pointer (lookup_reference_type (field_type),
- address + byte_offset);
+ v = value_at_lazy (field_type, address + byte_offset);
}
}
for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
{
+ /* FIXME pnh 2008/01/26: We check for a field that is
+ NOT wrapped in a struct, since the compiler sometimes
+ generates these for unchecked variant types. Revisit
+ if the compiler changes this practice. */
+ char *v_field_name = TYPE_FIELD_NAME (field_type, j);
disp = 0;
- t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
- name, 0, 1, &disp);
+ if (v_field_name != NULL
+ && field_name_match (v_field_name, name))
+ t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
+ else
+ t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
+ name, 0, 1, &disp);
+
if (t != NULL)
{
if (dispp != NULL)
return NULL;
}
+/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
+ within a value of type OUTER_TYPE, return true iff VAR_TYPE
+ represents an unchecked union (that is, the variant part of a
+ record that is named in an Unchecked_Union pragma). */
+
+static int
+is_unchecked_variant (struct type *var_type, struct type *outer_type)
+{
+ char *discrim_name = ada_variant_discrim_name (var_type);
+ return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
+ == NULL);
+}
+
+
/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
within a value of type OUTER_TYPE that is stored in GDB at
OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
{
int others_clause;
int i;
- int disp;
- struct type *discrim_type;
char *discrim_name = ada_variant_discrim_name (var_type);
+ struct value *outer;
+ struct value *discrim;
LONGEST discrim_val;
- disp = 0;
- discrim_type =
- ada_lookup_struct_elt_type (outer_type, discrim_name, 1, 1, &disp);
- if (discrim_type == NULL)
+ outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
+ discrim = ada_value_struct_elt (outer, discrim_name, 1);
+ if (discrim == NULL)
return -1;
- discrim_val = unpack_long (discrim_type, outer_valaddr + disp);
+ discrim_val = value_as_long (discrim);
others_clause = -1;
for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
static struct symbol *
find_old_style_renaming_symbol (const char *name, struct block *block)
{
- const struct symbol *function_sym = block_function (block);
+ const struct symbol *function_sym = block_linkage_function (block);
char *rename;
if (function_sym != NULL)
TYPE_CODE (type) = TYPE_CODE_STRUCT;
TYPE_NFIELDS (type) = 0;
TYPE_FIELDS (type) = NULL;
+ INIT_CPLUS_SPECIFIC (type);
TYPE_NAME (type) = "<empty>";
TYPE_TAG_NAME (type) = NULL;
- TYPE_FLAGS (type) = 0;
TYPE_LENGTH (type) = 0;
return type;
}
memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
TYPE_NAME (rtype) = ada_type_name (type);
TYPE_TAG_NAME (rtype) = NULL;
- TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;
+ TYPE_FIXED_INSTANCE (rtype) = 1;
off = 0;
bit_len = 0;
else
dval = dval0;
+ /* Get the fixed type of the field. Note that, in this case, we
+ do not want to get the real type out of the tag: if the current
+ field is the parent part of a tagged record, we will get the
+ tag of the object. Clearly wrong: the real type of the parent
+ is not the real type of the child. We would end up in an infinite
+ loop. */
TYPE_FIELD_TYPE (rtype, f) =
ada_to_fixed_type
(ada_get_base_type
(TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
- cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
+ cond_offset_target (address, off / TARGET_CHAR_BIT), dval, 0);
TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
bit_incr = fld_bit_len =
TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
}
/* We handle the variant part, if any, at the end because of certain
- odd cases in which it is re-ordered so as NOT the last field of
+ odd cases in which it is re-ordered so as NOT to be the last field of
the record. This can happen in the presence of representation
clauses. */
if (variant_field >= 0)
if (is_dynamic_field (type0, f))
new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
else
- new_type = to_static_fixed_type (field_type);
+ new_type = static_unwrap_type (field_type);
if (type == type0 && new_type != field_type)
{
TYPE_TARGET_TYPE (type0) = type = alloc_type (TYPE_OBJFILE (type0));
sizeof (struct field) * nfields);
TYPE_NAME (type) = ada_type_name (type0);
TYPE_TAG_NAME (type) = NULL;
- TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE;
+ TYPE_FIXED_INSTANCE (type) = 1;
TYPE_LENGTH (type) = 0;
}
TYPE_FIELD_TYPE (type, f) = new_type;
}
/* Given an object of type TYPE whose contents are at VALADDR and
- whose address in memory is ADDRESS, returns a revision of TYPE --
- a non-dynamic-sized record with a variant part -- in which
- the variant part is replaced with the appropriate branch. Looks
+ whose address in memory is ADDRESS, returns a revision of TYPE,
+ which should be a non-dynamic-sized record, in which the variant
+ part, if any, is replaced with the appropriate branch. Looks
for discriminant values in DVAL0, which can be NULL if the record
contains the necessary discriminant values. */
sizeof (struct field) * nfields);
TYPE_NAME (rtype) = ada_type_name (type);
TYPE_TAG_NAME (rtype) = NULL;
- TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;
+ TYPE_FIXED_INSTANCE (rtype) = 1;
TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
branch_type = to_fixed_variant_branch_type
{
struct type *templ_type;
- if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
+ if (TYPE_FIXED_INSTANCE (type0))
return type0;
templ_type = dynamic_template_type (type0);
}
else
{
- TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE;
+ TYPE_FIXED_INSTANCE (type0) = 1;
return type0;
}
union type. Any necessary discriminants' values should be in DVAL,
a record value. That is, this routine selects the appropriate
branch of the union at ADDR according to the discriminant value
- indicated in the union's type name. */
+ indicated in the union's type name. Returns VAR_TYPE0 itself if
+ it represents a variant subject to a pragma Unchecked_Union. */
static struct type *
to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
if (templ_type != NULL)
var_type = templ_type;
+ if (is_unchecked_variant (var_type, value_type (dval)))
+ return var_type0;
which =
ada_which_variant_applies (var_type,
value_type (dval), value_contents (dval));
struct type *result;
if (ada_is_packed_array_type (type0) /* revisit? */
- || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
+ || TYPE_FIXED_INSTANCE (type0))
return type0;
index_type_desc = ada_find_parallel_type (type0, "___XA");
the elements of an array of a tagged type should all be of
the same type specified in the debugging info. No need to
consult the object tag. */
- struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval);
+ struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
if (elt_type0 == elt_type)
result = type0;
the elements of an array of a tagged type should all be of
the same type specified in the debugging info. No need to
consult the object tag. */
- result = ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval);
+ result =
+ ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
{
struct type *range_type =
error (_("array type with dynamic size is larger than varsize-limit"));
}
- TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE;
+ TYPE_FIXED_INSTANCE (result) = 1;
return result;
}
and may be NULL if there are none, or if the object of type TYPE at
ADDRESS or in VALADDR contains these discriminants.
- In the case of tagged types, this function attempts to locate the object's
- tag and use it to compute the actual type. However, when ADDRESS is null,
- we cannot use it to determine the location of the tag, and therefore
- compute the tagged type's actual type. So we return the tagged type
- without consulting the tag. */
+ If CHECK_TAG is not null, in the case of tagged types, this function
+ attempts to locate the object's tag and use it to compute the actual
+ type. However, when ADDRESS is null, we cannot use it to determine the
+ location of the tag, and therefore compute the tagged type's actual type.
+ So we return the tagged type without consulting the tag. */
-struct type *
-ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
- CORE_ADDR address, struct value *dval)
+static struct type *
+ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
+ CORE_ADDR address, struct value *dval, int check_tag)
{
type = ada_check_typedef (type);
switch (TYPE_CODE (type))
case TYPE_CODE_STRUCT:
{
struct type *static_type = to_static_fixed_type (type);
-
+ struct type *fixed_record_type =
+ to_fixed_record_type (type, valaddr, address, NULL);
/* If STATIC_TYPE is a tagged type and we know the object's address,
then we can determine its tag, and compute the object's actual
- type from there. */
+ type from there. Note that we have to use the fixed record
+ type (the parent part of the record may have dynamic fields
+ and the way the location of _tag is expressed may depend on
+ them). */
- if (address != 0 && ada_is_tagged_type (static_type, 0))
+ if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
{
struct type *real_type =
- type_from_tag (value_tag_from_contents_and_address (static_type,
- valaddr,
- address));
+ type_from_tag (value_tag_from_contents_and_address
+ (fixed_record_type,
+ valaddr,
+ address));
if (real_type != NULL)
- type = real_type;
+ return to_fixed_record_type (real_type, valaddr, address, NULL);
+ }
+
+ /* Check to see if there is a parallel ___XVZ variable.
+ If there is, then it provides the actual size of our type. */
+ else if (ada_type_name (fixed_record_type) != NULL)
+ {
+ char *name = ada_type_name (fixed_record_type);
+ char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
+ int xvz_found = 0;
+ LONGEST size;
+
+ sprintf (xvz_name, "%s___XVZ", name);
+ size = get_int_var_value (xvz_name, &xvz_found);
+ if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
+ {
+ fixed_record_type = copy_type (fixed_record_type);
+ TYPE_LENGTH (fixed_record_type) = size;
+
+ /* The FIXED_RECORD_TYPE may have be a stub. We have
+ observed this when the debugging info is STABS, and
+ apparently it is something that is hard to fix.
+
+ In practice, we don't need the actual type definition
+ at all, because the presence of the XVZ variable allows us
+ to assume that there must be a XVS type as well, which we
+ should be able to use later, when we need the actual type
+ definition.
+
+ In the meantime, pretend that the "fixed" type we are
+ returning is NOT a stub, because this can cause trouble
+ when using this type to create new types targeting it.
+ Indeed, the associated creation routines often check
+ whether the target type is a stub and will try to replace
+ it, thus using a type with the wrong size. This, in turn,
+ might cause the new type to have the wrong size too.
+ Consider the case of an array, for instance, where the size
+ of the array is computed from the number of elements in
+ our array multiplied by the size of its element. */
+ TYPE_STUB (fixed_record_type) = 0;
+ }
}
- return to_fixed_record_type (type, valaddr, address, NULL);
+ return fixed_record_type;
}
case TYPE_CODE_ARRAY:
return to_fixed_array_type (type, dval, 1);
}
}
+/* The same as ada_to_fixed_type_1, except that it preserves the type
+ if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
+ ada_to_fixed_type_1 would return the type referenced by TYPE. */
+
+struct type *
+ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
+ CORE_ADDR address, struct value *dval, int check_tag)
+
+{
+ struct type *fixed_type =
+ ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
+
+ if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
+ && TYPE_TARGET_TYPE (type) == fixed_type)
+ return type;
+
+ return fixed_type;
+}
+
/* A standard (static-sized) type corresponding as well as possible to
TYPE0, but based on no runtime data. */
if (type0 == NULL)
return NULL;
- if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
+ if (TYPE_FIXED_INSTANCE (type0))
return type0;
type0 = ada_check_typedef (type0);
struct type *
ada_check_typedef (struct type *type)
{
+ if (type == NULL)
+ return NULL;
+
CHECK_TYPEDEF (type);
if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
|| !TYPE_STUB (type)
ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
struct value *val0)
{
- struct type *type = ada_to_fixed_type (type0, 0, address, NULL);
+ struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
if (type == type0 && val0 != NULL)
return val0;
else
static LONGEST
pos_atr (struct value *arg)
{
- struct type *type = value_type (arg);
+ struct value *val = coerce_ref (arg);
+ struct type *type = value_type (val);
if (!discrete_type_p (type))
error (_("'POS only defined on discrete types"));
if (TYPE_CODE (type) == TYPE_CODE_ENUM)
{
int i;
- LONGEST v = value_as_long (arg);
+ LONGEST v = value_as_long (val);
for (i = 0; i < TYPE_NFIELDS (type); i += 1)
{
error (_("enumeration value is invalid: can't find 'POS"));
}
else
- return value_as_long (arg);
+ return value_as_long (val);
}
static struct value *
-value_pos_atr (struct value *arg)
+value_pos_atr (struct type *type, struct value *arg)
{
- return value_from_longest (builtin_type_int, pos_atr (arg));
+ return value_from_longest (type, pos_atr (arg));
}
/* Evaluate the TYPE'VAL attribute applied to ARG. */
int
ada_is_character_type (struct type *type)
{
- const char *name = ada_type_name (type);
- return
- name != NULL
- && (TYPE_CODE (type) == TYPE_CODE_CHAR
- || TYPE_CODE (type) == TYPE_CODE_INT
- || TYPE_CODE (type) == TYPE_CODE_RANGE)
- && (strcmp (name, "character") == 0
- || strcmp (name, "wide_character") == 0
- || strcmp (name, "unsigned char") == 0);
+ const char *name;
+
+ /* If the type code says it's a character, then assume it really is,
+ and don't check any further. */
+ if (TYPE_CODE (type) == TYPE_CODE_CHAR)
+ return 1;
+
+ /* Otherwise, assume it's a character type iff it is a discrete type
+ with a known character type name. */
+ name = ada_type_name (type);
+ return (name != NULL
+ && (TYPE_CODE (type) == TYPE_CODE_INT
+ || TYPE_CODE (type) == TYPE_CODE_RANGE)
+ && (strcmp (name, "character") == 0
+ || strcmp (name, "wide_character") == 0
+ || strcmp (name, "wide_wide_character") == 0
+ || strcmp (name, "unsigned char") == 0));
}
/* True if TYPE appears to be an Ada string type. */
struct type *type = ada_check_typedef (value_type (val));
if (ada_is_aligner_type (type))
{
- struct value *v = value_struct_elt (&val, NULL, "F",
- NULL, "internal structure");
+ struct value *v = ada_value_struct_elt (val, "F", 0);
struct type *val_type = ada_check_typedef (value_type (v));
if (ada_type_name (val_type) == NULL)
TYPE_NAME (val_type) = ada_type_name (type);
coerce_unspec_val_to_type
(val, ada_to_fixed_type (raw_real_type, 0,
VALUE_ADDRESS (val) + value_offset (val),
- NULL));
+ NULL, 1));
}
}
value_as_long (arg)));
else
{
- DOUBLEST argd =
- value_as_double (value_cast (builtin_type_double, value_copy (arg)));
+ DOUBLEST argd = value_as_double (arg);
val = ada_float_to_fixed (type, argd);
}
}
static struct value *
-cast_from_fixed_to_double (struct value *arg)
+cast_from_fixed (struct type *type, struct value *arg)
{
DOUBLEST val = ada_fixed_to_float (value_type (arg),
value_as_long (arg));
- return value_from_double (builtin_type_double, val);
+ return value_from_double (type, val);
}
/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
if (ada_is_direct_array_type (value_type (arg1))
|| ada_is_direct_array_type (value_type (arg2)))
{
+ /* Automatically dereference any array reference before
+ we attempt to perform the comparison. */
+ arg1 = ada_coerce_ref (arg1);
+ arg2 = ada_coerce_ref (arg2);
+
arg1 = ada_coerce_to_simple_array (arg1);
arg2 = ada_coerce_to_simple_array (arg2);
if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
struct value *elt;
if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
{
- struct value *index_val = value_from_longest (builtin_type_int, index);
+ struct value *index_val = value_from_longest (builtin_type_int32, index);
elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
}
else
indices[i + 1] = high;
}
+/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
+ is different. */
+
+static struct value *
+ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
+{
+ if (type == ada_check_typedef (value_type (arg2)))
+ return arg2;
+
+ if (ada_is_fixed_point_type (type))
+ return (cast_to_fixed (type, arg2));
+
+ if (ada_is_fixed_point_type (value_type (arg2)))
+ return cast_from_fixed (type, arg2);
+
+ return value_cast (type, arg2);
+}
+
static struct value *
ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
int *pos, enum noside noside)
{
default:
*pos -= 1;
- return
- unwrap_value (evaluate_subexp_standard
- (expect_type, exp, pos, noside));
+ arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
+ arg1 = unwrap_value (arg1);
+
+ /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
+ then we need to perform the conversion manually, because
+ evaluate_subexp_standard doesn't do it. This conversion is
+ necessary in Ada because the different kinds of float/fixed
+ types in Ada have different representations.
+
+ Similarly, we need to perform the conversion from OP_LONG
+ ourselves. */
+ if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
+ arg1 = ada_value_cast (expect_type, arg1, noside);
+
+ return arg1;
case OP_STRING:
{
arg1 = evaluate_subexp (type, exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
- if (type != ada_check_typedef (value_type (arg1)))
- {
- if (ada_is_fixed_point_type (type))
- arg1 = cast_to_fixed (type, arg1);
- else if (ada_is_fixed_point_type (value_type (arg1)))
- arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
- else if (VALUE_LVAL (arg1) == lval_memory)
- {
- /* This is in case of the really obscure (and undocumented,
- but apparently expected) case of (Foo) Bar.all, where Bar
- is an integer constant and Foo is a dynamic-sized type.
- If we don't do this, ARG1 will simply be relabeled with
- TYPE. */
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (to_static_fixed_type (type), not_lval);
- arg1 =
- ada_to_fixed_value_create
- (type, VALUE_ADDRESS (arg1) + value_offset (arg1), 0);
- }
- else
- arg1 = value_cast (type, arg1);
- }
+ arg1 = ada_value_cast (type, arg1, noside);
return arg1;
case UNOP_QUAL:
return arg1;
return ada_value_assign (arg1, arg1);
}
- arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
+ /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
+ except if the lhs of our assignment is a convenience variable.
+ In the case of assigning to a convenience variable, the lhs
+ should be exactly the result of the evaluation of the rhs. */
+ type = value_type (arg1);
+ if (VALUE_LVAL (arg1) == lval_internalvar)
+ type = NULL;
+ arg2 = evaluate_subexp (type, exp, pos, noside);
if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
return arg1;
if (ada_is_fixed_point_type (value_type (arg1)))
arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
+ if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
+ return (value_from_longest
+ (value_type (arg1),
+ 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))
error (_("Operands of fixed-point addition must have the same type"));
- return value_cast (value_type (arg1), value_add (arg1, arg2));
+ /* Do the addition, and cast the result to the type of the first
+ argument. We cannot cast the result to a reference type, so if
+ ARG1 is a reference type, find its underlying type. */
+ type = value_type (arg1);
+ while (TYPE_CODE (type) == TYPE_CODE_REF)
+ type = TYPE_TARGET_TYPE (type);
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
case BINOP_SUB:
arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
+ if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
+ return (value_from_longest
+ (value_type (arg1),
+ 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))
error (_("Operands of fixed-point subtraction must have the same type"));
- return value_cast (value_type (arg1), value_sub (arg1, arg2));
+ /* Do the substraction, and cast the result to the type of the first
+ argument. We cannot cast the result to a reference type, so if
+ ARG1 is a reference type, find its underlying type. */
+ type = value_type (arg1);
+ while (TYPE_CODE (type) == TYPE_CODE_REF)
+ type = TYPE_TARGET_TYPE (type);
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
case BINOP_MUL:
case BINOP_DIV:
return value_zero (value_type (arg1), not_lval);
else
{
+ type = builtin_type (exp->gdbarch)->builtin_double;
if (ada_is_fixed_point_type (value_type (arg1)))
- arg1 = cast_from_fixed_to_double (arg1);
+ arg1 = cast_from_fixed (type, arg1);
if (ada_is_fixed_point_type (value_type (arg2)))
- arg2 = cast_from_fixed_to_double (arg2);
+ arg2 = cast_from_fixed (type, arg2);
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
return ada_value_binop (arg1, arg2, op);
}
&& (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
return value_zero (value_type (arg1), not_lval);
else
- return ada_value_binop (arg1, arg2, op);
+ {
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ return ada_value_binop (arg1, arg2, op);
+ }
case BINOP_EQUAL:
case BINOP_NOTEQUAL:
if (noside == EVAL_AVOID_SIDE_EFFECTS)
tem = 0;
else
- tem = ada_value_equal (arg1, arg2);
+ {
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ tem = ada_value_equal (arg1, arg2);
+ }
if (op == BINOP_NOTEQUAL)
tem = !tem;
- return value_from_longest (LA_BOOL_TYPE, (LONGEST) tem);
+ type = language_bool_type (exp->language_defn, exp->gdbarch);
+ return value_from_longest (type, (LONGEST) tem);
case UNOP_NEG:
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
else if (ada_is_fixed_point_type (value_type (arg1)))
return value_cast (value_type (arg1), value_neg (arg1));
else
- return value_neg (arg1);
+ {
+ unop_promote (exp->language_defn, exp->gdbarch, &arg1);
+ return value_neg (arg1);
+ }
+
+ case BINOP_LOGICAL_AND:
+ case BINOP_LOGICAL_OR:
+ case UNOP_LOGICAL_NOT:
+ {
+ struct value *val;
+
+ *pos -= 1;
+ val = evaluate_subexp_standard (expect_type, exp, pos, noside);
+ type = language_bool_type (exp->language_defn, exp->gdbarch);
+ return value_cast (type, val);
+ }
+
+ case BINOP_BITWISE_AND:
+ case BINOP_BITWISE_IOR:
+ case BINOP_BITWISE_XOR:
+ {
+ struct value *val;
+
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
+ *pos = pc;
+ val = evaluate_subexp_standard (expect_type, exp, pos, noside);
+
+ return value_cast (value_type (arg1), val);
+ }
case OP_VAR_VALUE:
*pos -= 1;
+
if (noside == EVAL_SKIP)
{
*pos += 4;
SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
else if (noside == EVAL_AVOID_SIDE_EFFECTS)
{
+ type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
+ if (ada_is_tagged_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);
+ return value_zero (type_from_tag (ada_value_tag (arg1)), not_lval);
+ }
+
*pos += 4;
return value_zero
(to_static_fixed_type
if (arity != nargs)
error (_("wrong number of subscripts; expecting %d"), arity);
if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return allocate_value (ada_aligned_type (type));
+ return value_zero (ada_aligned_type (type), lval_memory);
return
unwrap_value (ada_value_subscript
(argvec[0], nargs, argvec + 1));
if (type == NULL)
error (_("element type of array unknown"));
else
- return allocate_value (ada_aligned_type (type));
+ return value_zero (ada_aligned_type (type), lval_memory);
}
return
unwrap_value (ada_value_subscript
if (type == NULL)
error (_("element type of array unknown"));
else
- return allocate_value (ada_aligned_type (type));
+ return value_zero (ada_aligned_type (type), lval_memory);
}
return
unwrap_value (ada_value_ptr_subscript (argvec[0], type,
struct type *arr_type0 =
to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
NULL, 1);
- return ada_value_slice_ptr (array, arr_type0,
- longest_to_int (low_bound),
- longest_to_int (high_bound));
+ return ada_value_slice_from_ptr (array, arr_type0,
+ longest_to_int (low_bound),
+ longest_to_int (high_bound));
}
}
else if (noside == EVAL_AVOID_SIDE_EFFECTS)
default:
lim_warning (_("Membership test incompletely implemented; "
"always returns true"));
- return value_from_longest (builtin_type_int, (LONGEST) 1);
+ type = language_bool_type (exp->language_defn, exp->gdbarch);
+ return value_from_longest (type, (LONGEST) 1);
case TYPE_CODE_RANGE:
- arg2 = value_from_longest (builtin_type_int, TYPE_LOW_BOUND (type));
- arg3 = value_from_longest (builtin_type_int,
- TYPE_HIGH_BOUND (type));
- return
- value_from_longest (builtin_type_int,
+ arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
+ arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
+ type = language_bool_type (exp->language_defn, exp->gdbarch);
+ return
+ value_from_longest (type,
(value_less (arg1, arg3)
|| value_equal (arg1, arg3))
&& (value_less (arg2, arg1)
goto nosideret;
if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (builtin_type_int, not_lval);
+ {
+ type = language_bool_type (exp->language_defn, exp->gdbarch);
+ return value_zero (type, not_lval);
+ }
tem = longest_to_int (exp->elts[pc + 1].longconst);
arg3 = ada_array_bound (arg2, tem, 1);
arg2 = ada_array_bound (arg2, tem, 0);
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
+ type = language_bool_type (exp->language_defn, exp->gdbarch);
return
- value_from_longest (builtin_type_int,
+ value_from_longest (type,
(value_less (arg1, arg3)
|| value_equal (arg1, arg3))
&& (value_less (arg2, arg1)
if (noside == EVAL_SKIP)
goto nosideret;
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
+ type = language_bool_type (exp->language_defn, exp->gdbarch);
return
- value_from_longest (builtin_type_int,
+ value_from_longest (type,
(value_less (arg1, arg3)
|| value_equal (arg1, arg3))
&& (value_less (arg2, arg1)
default:
error (_("unexpected attribute encountered"));
case OP_ATR_FIRST:
- return discrete_type_low_bound (range_type);
+ return value_from_longest
+ (range_type, discrete_type_low_bound (range_type));
case OP_ATR_LAST:
- return discrete_type_high_bound (range_type);
+ return value_from_longest
+ (range_type, discrete_type_high_bound (range_type));
case OP_ATR_LENGTH:
error (_("the 'length attribute applies only to array types"));
}
else if (noside == EVAL_AVOID_SIDE_EFFECTS)
return value_zero (value_type (arg1), not_lval);
else
- return value_binop (arg1, arg2,
- op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
+ {
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ return value_binop (arg1, arg2,
+ op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
+ }
case OP_ATR_MODULUS:
{
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (builtin_type_int, not_lval);
+ type = builtin_type (exp->gdbarch)->builtin_int;
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (type, not_lval);
else
- return value_pos_atr (arg1);
+ return value_pos_atr (type, arg1);
case OP_ATR_SIZE:
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ type = value_type (arg1);
+
+ /* If the argument is a reference, then dereference its type, since
+ the user is really asking for the size of the actual object,
+ not the size of the pointer. */
+ if (TYPE_CODE (type) == TYPE_CODE_REF)
+ type = TYPE_TARGET_TYPE (type);
+
if (noside == EVAL_SKIP)
goto nosideret;
else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (builtin_type_int, not_lval);
+ return value_zero (builtin_type_int32, not_lval);
else
- return value_from_longest (builtin_type_int,
- TARGET_CHAR_BIT
- * TYPE_LENGTH (value_type (arg1)));
+ return value_from_longest (builtin_type_int32,
+ TARGET_CHAR_BIT * TYPE_LENGTH (type));
case OP_ATR_VAL:
evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
else if (noside == EVAL_AVOID_SIDE_EFFECTS)
return value_zero (value_type (arg1), not_lval);
else
- return value_binop (arg1, arg2, op);
+ {
+ /* For integer exponentiation operations,
+ only promote the first argument. */
+ if (is_integral_type (value_type (arg2)))
+ unop_promote (exp->language_defn, exp->gdbarch, &arg1);
+ else
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+
+ return value_binop (arg1, arg2, op);
+ }
case UNOP_PLUS:
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
+ unop_promote (exp->language_defn, exp->gdbarch, &arg1);
if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
return value_neg (arg1);
else
return arg1;
case UNOP_IND:
- if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
- expect_type = TYPE_TARGET_TYPE (ada_check_typedef (expect_type));
- arg1 = evaluate_subexp (expect_type, exp, pos, noside);
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
type = ada_check_typedef (value_type (arg1));
return value_zero (type, lval_memory);
}
else if (TYPE_CODE (type) == TYPE_CODE_INT)
- /* GDB allows dereferencing an int. */
- return value_zero (builtin_type_int, lval_memory);
+ {
+ /* GDB allows dereferencing an int. */
+ if (expect_type == NULL)
+ return value_zero (builtin_type (exp->gdbarch)->builtin_int,
+ lval_memory);
+ else
+ {
+ expect_type =
+ to_static_fixed_type (ada_aligned_type (expect_type));
+ return value_zero (expect_type, lval_memory);
+ }
+ }
else
error (_("Attempt to take contents of a non-pointer value."));
}
arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
type = ada_check_typedef (value_type (arg1));
+ if (TYPE_CODE (type) == TYPE_CODE_INT)
+ /* GDB allows dereferencing an int. If we were given
+ the expect_type, then use that as the target type.
+ Otherwise, assume that the target type is an int. */
+ {
+ if (expect_type != NULL)
+ return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
+ arg1));
+ else
+ return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
+ (CORE_ADDR) value_as_address (arg1));
+ }
+
if (ada_is_array_descriptor_type (type))
/* GDB allows dereferencing GNAT array descriptors. */
return ada_coerce_to_simple_array (arg1);
}
nosideret:
- return value_from_longest (builtin_type_long, (LONGEST) 1);
+ return value_from_longest (builtin_type_int8, (LONGEST) 1);
}
\f
char *subtype_info;
if (raw_type == NULL)
- base_type = builtin_type_int;
+ base_type = builtin_type_int32;
else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
base_type = TYPE_TARGET_TYPE (raw_type);
else
subtype_info = strstr (name, "___XD");
if (subtype_info == NULL)
- return raw_type;
+ {
+ LONGEST L = discrete_type_low_bound (raw_type);
+ LONGEST U = discrete_type_high_bound (raw_type);
+ if (L < INT_MIN || U > INT_MAX)
+ return raw_type;
+ else
+ return create_range_type (alloc_type (objfile), raw_type,
+ discrete_type_low_bound (raw_type),
+ discrete_type_high_bound (raw_type));
+ }
else
{
static char *name_buf = NULL;
struct type *subranged_type = base_type (type);
return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
- && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
+ && TYPE_CODE (subranged_type) == TYPE_CODE_INT
&& TYPE_UNSIGNED (subranged_type));
}
ULONGEST
ada_modulus (struct type * type)
{
- return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
+ return (ULONGEST) (unsigned int) TYPE_HIGH_BOUND (type) + 1;
}
\f
ex_catch_assert
};
+/* Ada's standard exceptions. */
+
+static char *standard_exc[] = {
+ "constraint_error",
+ "program_error",
+ "storage_error",
+ "tasking_error"
+};
+
typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
/* A structure that describes how to support exception catchpoints
each time a new executable is loaded by GDB. */
static void
-ada_executable_changed_observer (void *unused)
+ada_executable_changed_observer (void)
{
/* If the executable changed, then it is possible that the Ada runtime
is different. So we need to invalidate the exception support info
/* Find the first frame that contains debugging information and that is not
part of the Ada run-time, starting from FI and moving upward. */
-static void
+void
ada_find_printable_frame (struct frame_info *fi)
{
for (; fi != NULL; fi = get_prev_frame (fi))
print_one_exception (enum exception_catchpoint_kind ex,
struct breakpoint *b, CORE_ADDR *last_addr)
{
- if (addressprint)
+ struct value_print_options opts;
+
+ get_user_print_options (&opts);
+ if (opts.addressprint)
{
annotate_field (4);
ui_out_field_core_addr (uiout, "addr", b->loc->address);
static struct breakpoint_ops catch_exception_breakpoint_ops =
{
+ NULL, /* insert */
+ NULL, /* remove */
+ NULL, /* breakpoint_hit */
print_it_catch_exception,
print_one_catch_exception,
print_mention_catch_exception
}
static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops = {
+ NULL, /* insert */
+ NULL, /* remove */
+ NULL, /* breakpoint_hit */
print_it_catch_exception_unhandled,
print_one_catch_exception_unhandled,
print_mention_catch_exception_unhandled
}
static struct breakpoint_ops catch_assert_breakpoint_ops = {
+ NULL, /* insert */
+ NULL, /* remove */
+ NULL, /* breakpoint_hit */
print_it_catch_assert,
print_one_catch_assert,
print_mention_catch_assert
static char *
ada_exception_catchpoint_cond_string (const char *exp_string)
{
+ int i;
+
+ /* The standard exceptions are a special case. They are defined in
+ runtime units that have been compiled without debugging info; if
+ EXP_STRING is the not-fully-qualified name of a standard
+ exception (e.g. "constraint_error") then, during the evaluation
+ of the condition expression, the symbol lookup on this name would
+ *not* return this standard exception. The catchpoint condition
+ may then be set only on user-defined exceptions which have the
+ same not-fully-qualified name (e.g. my_package.constraint_error).
+
+ To avoid this unexcepted behavior, these standard exceptions are
+ systematically prefixed by "standard". This means that "catch
+ exception constraint_error" is rewritten into "catch exception
+ standard.constraint_error".
+
+ If an exception named contraint_error is defined in another package of
+ the inferior program, then the only way to specify this exception as a
+ breakpoint condition is to use its fully-qualified named:
+ e.g. my_package.constraint_error. */
+
+ for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
+ {
+ if (strcmp (standard_exc [i], exp_string) == 0)
+ {
+ return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
+ exp_string);
+ }
+ }
return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string);
}
(struct objfile *) NULL));
TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
= "system__address";
+
+ lai->bool_type_symbol = "boolean";
+ lai->bool_type_default = builtin->builtin_bool;
}
\f
/* Language vector */
case_sensitive_on, /* Yes, Ada is case-insensitive, but
that's not quite what this means. */
array_row_major,
+ macro_expansion_no,
&ada_exp_descriptor,
parse,
ada_error,
ada_printstr, /* Function to print string constant */
emit_char, /* Function to print single char (not used) */
ada_print_type, /* Print a type using appropriate syntax */
+ default_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 */
NULL, /* Language specific skip_trampoline */
- NULL, /* value_of_this */
+ NULL, /* name_of_this */
ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
basic_lookup_transparent_type, /* lookup_transparent_type */
ada_la_decode, /* Language specific symbol demangler */
0, /* c-style arrays */
1, /* String lower bound */
ada_get_gdb_completer_word_break_characters,
+ ada_make_symbol_completion_list,
ada_language_arch_info,
ada_print_array_index,
default_pass_by_reference,
decoded_names_store = htab_create_alloc
(256, htab_hash_string, (int (*)(const void *, const void *)) streq,
NULL, xcalloc, xfree);
+
+ observer_attach_executable_changed (ada_executable_changed_observer);
}
projects / deliverable / binutils-gdb.git / blobdiff