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 *);
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'));
else if (!ADA_RETAIN_DOTS
&& 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;
{
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);
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)
{
index_type_desc = ada_find_parallel_type (type, "___XA");
if (index_type_desc == NULL)
{
- struct type *range_type;
struct type *index_type;
while (n > 1)
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;
+ index_type = TYPE_INDEX_TYPE (type);
if (typep != NULL)
*typep = index_type;
+
+ /* The index type is either a range type or an enumerated type.
+ For the range type, we have some macros that allow us to
+ extract the value of the low and high bounds. But they
+ do now work for enumerated types. The expressions used
+ below work for both range and enum types. */
return
(LONGEST) (which == 0
- ? TYPE_LOW_BOUND (range_type)
- : TYPE_HIGH_BOUND (range_type));
+ ? TYPE_FIELD_BITPOS (index_type, 0)
+ : TYPE_FIELD_BITPOS (index_type,
+ TYPE_NFIELDS (index_type) - 1));
}
else
{
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);
+ *typep = index_type;
+
return
(LONGEST) (which == 0
? TYPE_LOW_BOUND (index_type)
}
/* Given that arr is an array value, returns the lower bound of the
- nth index (numbering from 1) if which is 0, and the upper bound if
- which is 1. This routine will also work for arrays with bounds
+ 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 *
break;
case OP_TYPE:
+ case OP_REGISTER:
return NULL;
}
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. */
names (e.g., XVE) are not included here. Currently, the possible suffixes
are given by either of the regular expression:
- (__[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')
\f
/* Field Access */
+/* 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);
+}
+
/* 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
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))
{
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)
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;
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));
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 =
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);
}
- 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. */
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
|| 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));
}
coerce_unspec_val_to_type
(val, ada_to_fixed_type (raw_real_type, 0,
VALUE_ADDRESS (val) + value_offset (val),
- NULL));
+ NULL, 1));
}
}
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
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 value_cast (type, cast_from_fixed_to_double (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:
|| 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);
+ return value_cast (type, value_add (arg1, arg2));
case BINOP_SUB:
arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
|| 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);
+ return value_cast (type, value_sub (arg1, arg2));
case BINOP_MUL:
case BINOP_DIV:
else
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);
+ return value_cast (LA_BOOL_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;
+
+ /* Tagged types are a little special in the fact that the real type
+ is dynamic and can only be determined by inspecting the object
+ value. So even if we're support to do an EVAL_AVOID_SIDE_EFFECTS
+ evaluation, we force an EVAL_NORMAL evaluation for tagged types. */
+ if (noside == EVAL_AVOID_SIDE_EFFECTS
+ && ada_is_tagged_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol), 1))
+ noside = EVAL_NORMAL;
+
if (noside == EVAL_SKIP)
{
*pos += 4;
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,
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);
}