/* Ada language support routines for GDB, the GNU debugger. Copyright (C)
- 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007
- Free Software Foundation, Inc.
+ 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007, 2008,
+ 2009 Free Software Foundation, Inc.
This file is part of GDB.
#include "observer.h"
#include "vec.h"
-#ifndef ADA_RETAIN_DOTS
-#define ADA_RETAIN_DOTS 0
-#endif
-
/* Define whether or not the C operator '/' truncates towards zero for
differently signed operands (truncation direction is undefined in C).
Copied from valarith.c. */
static int fat_pntr_bounds_bitsize (struct type *);
-static struct type *desc_data_type (struct type *);
+static struct type *desc_data_target_type (struct type *);
static struct value *desc_data (struct value *);
*, const char *, int,
domain_enum, int);
-static struct symtab *symtab_for_sym (struct symbol *);
-
static struct value *resolve_subexp (struct expression **, int *, int,
struct type *);
static int is_name_suffix (const char *);
-static int is_digits_suffix (const char *str);
-
static int wild_match (const char *, int, const char *);
static struct value *ada_coerce_ref (struct value *);
static char *result = NULL;
xfree (result);
- result = (char *) xmalloc ((strlen (str) + 3) * sizeof (char));
-
- sprintf (result, "<%s>", str);
+ result = xstrprintf ("<%s>", str);
return result;
}
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, " => ");
}
}
-/* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
- FIELD_NAME, and return its index. This function also handles fields
- whose name have ___ suffixes because the compiler sometimes alters
- their name by adding such a suffix to represent fields with certain
- constraints. If the field could not be found, return a negative
- number if MAYBE_MISSING is set. Otherwise raise an error. */
+/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
+ a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
+ and return its index. This function also handles fields whose name
+ have ___ suffixes because the compiler sometimes alters their name
+ by adding such a suffix to represent fields with certain constraints.
+ If the field could not be found, return a negative number if
+ MAYBE_MISSING is set. Otherwise raise an error. */
int
ada_get_field_index (const struct type *type, const char *field_name,
int maybe_missing)
{
int fieldno;
- for (fieldno = 0; fieldno < TYPE_NFIELDS (type); fieldno++)
- if (field_name_match (TYPE_FIELD_NAME (type, fieldno), field_name))
+ struct type *struct_type = check_typedef ((struct type *) type);
+
+ for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
+ if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
return fieldno;
if (!maybe_missing)
error (_("Unable to find field %s in struct %s. Aborting"),
- field_name, TYPE_NAME (type));
+ field_name, TYPE_NAME (struct_type));
return -1;
}
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);
ada_main_name (void)
{
struct minimal_symbol *msym;
- CORE_ADDR main_program_name_addr;
- static char main_program_name[1024];
+ static char *main_program_name = NULL;
/* For Ada, the name of the main procedure is stored in a specific
string constant, generated by the binder. Look for that symbol,
if (msym != NULL)
{
+ CORE_ADDR main_program_name_addr;
+ int err_code;
+
main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
if (main_program_name_addr == 0)
error (_("Invalid address for Ada main program name."));
- extract_string (main_program_name_addr, main_program_name);
+ xfree (main_program_name);
+ target_read_string (main_program_name_addr, &main_program_name,
+ 1024, &err_code);
+
+ if (err_code != 0)
+ return NULL;
return main_program_name;
}
{NULL, NULL}
};
-/* Return non-zero if STR should be suppressed in info listings. */
-
-static int
-is_suppressed_name (const char *str)
-{
- if (strncmp (str, "_ada_", 5) == 0)
- str += 5;
- if (str[0] == '_' || str[0] == '\000')
- return 1;
- else
- {
- const char *p;
- const char *suffix = strstr (str, "___");
- if (suffix != NULL && suffix[3] != 'X')
- return 1;
- if (suffix == NULL)
- suffix = str + strlen (str);
- for (p = suffix - 1; p != str; p -= 1)
- if (isupper (*p))
- {
- int i;
- if (p[0] == 'X' && p[-1] != '_')
- goto OK;
- if (*p != 'O')
- return 1;
- for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
- if (strncmp (ada_opname_table[i].encoded, p,
- strlen (ada_opname_table[i].encoded)) == 0)
- goto OK;
- return 1;
- OK:;
- }
- return 0;
- }
-}
-
/* The "encoded" form of DECODED, according to GNAT conventions.
The result is valid until the next call to ada_encode. */
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;
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] = '.';
if (encoded[0] == '<')
strcpy (decoded, encoded);
else
- sprintf (decoded, "<%s>", encoded);
+ xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
return decoded;
}
return *resultp;
}
-char *
+static char *
ada_la_decode (const char *encoded, int options)
{
return xstrdup (ada_decode (encoded));
suffix of SYM_NAME minus the same suffixes. Also returns 0 if
either argument is NULL. */
-int
+static int
ada_match_name (const char *sym_name, const char *name, int wild)
{
if (sym_name == NULL || name == NULL)
&& is_name_suffix (sym_name + len_name + 5));
}
}
-
-/* True (non-zero) iff, in Ada mode, the symbol SYM should be
- suppressed in info listings. */
-
-int
-ada_suppress_symbol_printing (struct symbol *sym)
-{
- if (SYMBOL_DOMAIN (sym) == STRUCT_DOMAIN)
- return 1;
- else
- return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym));
-}
\f
/* Arrays */
thin_data_pntr (struct value *val)
{
struct type *type = value_type (val);
+ struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
+ data_type = lookup_pointer_type (data_type);
+
if (TYPE_CODE (type) == TYPE_CODE_PTR)
- return value_cast (desc_data_type (thin_descriptor_type (type)),
- value_copy (val));
+ return value_cast (data_type, value_copy (val));
else
- return value_from_longest (desc_data_type (thin_descriptor_type (type)),
+ return value_from_longest (data_type,
VALUE_ADDRESS (val) + value_offset (val));
}
}
/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
- pointer to one, the type of its array data (a
- pointer-to-array-with-no-bounds type); otherwise, NULL. Use
- ada_type_of_array to get an array type with bounds data. */
+ pointer to one, the type of its array data (a array-with-no-bounds type);
+ otherwise, NULL. Use ada_type_of_array to get an array type with bounds
+ data. */
static struct type *
-desc_data_type (struct type *type)
+desc_data_target_type (struct type *type)
{
type = desc_base_type (type);
/* NOTE: The following is bogus; see comment in desc_bounds. */
if (is_thin_pntr (type))
- return lookup_pointer_type
- (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
+ return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
else if (is_thick_pntr (type))
- return lookup_struct_elt_type (type, "P_ARRAY", 1);
- else
- return NULL;
+ {
+ struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
+
+ if (data_type
+ && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
+ return TYPE_TARGET_TYPE (data_type);
+ }
+
+ return NULL;
}
/* If ARR is an array descriptor (fat or thin pointer), a pointer to
/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
* to one. */
-int
+static int
ada_is_array_type (struct type *type)
{
while (type != NULL
int
ada_is_array_descriptor_type (struct type *type)
{
- struct type *data_type = desc_data_type (type);
+ struct type *data_type = desc_data_target_type (type);
if (type == NULL)
return 0;
type = ada_check_typedef (type);
- return
- data_type != NULL
- && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
- && TYPE_TARGET_TYPE (data_type) != NULL
- && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
- || TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
- && desc_arity (desc_bounds_type (type)) > 0;
+ return (data_type != NULL
+ && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
+ && desc_arity (desc_bounds_type (type)) > 0);
}
/* Non-zero iff type is a partially mal-formed GNAT array
if (!bounds)
return
- ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr))));
+ ada_check_typedef (desc_data_target_type (value_type (arr)));
else
{
struct type *elt_type;
struct type *
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 type *result;
- deprecated_set_value_type (dummy, type);
- result = ada_type_of_array (dummy, 0);
- value_free_to_mark (mark);
- return result;
+ if (ada_is_packed_array_type (type))
+ return decode_packed_array_type (type);
+
+ if (ada_is_array_descriptor_type (type))
+ return ada_check_typedef (desc_data_target_type (type));
+
+ return type;
}
/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
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)
return NULL;
}
shadow_type = SYMBOL_TYPE (sym);
+ CHECK_TYPEDEF (shadow_type);
if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
{
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)
/* ... And are placed at the beginning (most-significant) bytes
of the target. */
targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
+ ntarg = targ + 1;
break;
default:
accumSize = 0;
value of the element of *ARR at the ARITY indices given in
IND. Does not read the entire array into memory. */
-struct value *
+static struct value *
ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
struct value **ind)
{
}
/* 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);
}
int k;
struct type *p_array_type;
- p_array_type = desc_data_type (type);
+ p_array_type = desc_data_target_type (type);
k = ada_array_arity (type);
if (k == 0)
/* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
if (nindices >= 0 && k > nindices)
k = nindices;
- p_array_type = TYPE_TARGET_TYPE (p_array_type);
while (k > 0 && p_array_type != NULL)
{
p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
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;
}
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 *index_type;
-
while (n > 1)
{
type = TYPE_TARGET_TYPE (type);
}
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_FIELD_BITPOS (index_type, 0)
- : TYPE_FIELD_BITPOS (index_type,
- TYPE_NFIELDS (index_type) - 1));
}
- 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));
+ 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;
+ if (typep != NULL)
+ *typep = index_type;
- return
- (LONGEST) (which == 0
- ? TYPE_LOW_BOUND (index_type)
- : TYPE_HIGH_BOUND (index_type));
- }
+ return retval;
}
/* Given that arr is an array value, returns the lower bound of the
Does not work for arrays indexed by enumeration types with representation
clauses at the moment. */
-struct value *
+static struct value *
ada_array_length (struct value *arr, int n)
{
struct type *arr_type = ada_check_typedef (value_type (arr));
case UNOP_QUAL:
*pos += 3;
- resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
+ resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
break;
case OP_ATR_MODULUS:
(SYMBOL_CLASS (syms[i].sym) == LOC_CONST
&& SYMBOL_TYPE (syms[i].sym) != NULL
&& TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
- struct symtab *symtab = symtab_for_sym (syms[i].sym);
+ struct symtab *symtab = syms[i].sym->symtab;
if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
printf_unfiltered (_("[%d] %s at %s:%d\n"),
return NULL;
}
-/* Find a symbol table containing symbol SYM or NULL if none. */
-
-static struct symtab *
-symtab_for_sym (struct symbol *sym)
-{
- struct symtab *s;
- struct objfile *objfile;
- struct block *b;
- struct symbol *tmp_sym;
- struct dict_iterator iter;
- int j;
-
- ALL_PRIMARY_SYMTABS (objfile, s)
- {
- switch (SYMBOL_CLASS (sym))
- {
- case LOC_CONST:
- case LOC_STATIC:
- case LOC_TYPEDEF:
- case LOC_REGISTER:
- case LOC_LABEL:
- case LOC_BLOCK:
- case LOC_CONST_BYTES:
- b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
- ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
- return s;
- b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
- ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
- return s;
- break;
- default:
- break;
- }
- switch (SYMBOL_CLASS (sym))
- {
- case LOC_REGISTER:
- case LOC_ARG:
- case LOC_REF_ARG:
- case LOC_REGPARM_ADDR:
- case LOC_LOCAL:
- case LOC_TYPEDEF:
- case LOC_COMPUTED:
- for (j = FIRST_LOCAL_BLOCK;
- j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
- {
- b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
- ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
- return s;
- }
- break;
- default:
- break;
- }
- }
- return NULL;
-}
-
/* Return a minimal symbol matching NAME according to Ada decoding
rules. Returns NULL if there is no such minimal symbol. Names
prefixed with "standard__" are handled specially: "standard__" is
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;
}
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) tuples,
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, 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))
{
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, 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);
- char *raw_name = SYMBOL_LINKAGE_NAME (msymbol);
- char *name1;
- const char *suffix;
- QUIT;
- suffix = strrchr (raw_name, '.');
- if (suffix == NULL)
- suffix = strrchr (raw_name, '$');
- if (suffix != NULL && is_digits_suffix (suffix + 1))
- {
- name1 = alloca (suffix - raw_name + 1);
- strncpy (name1, raw_name, suffix - raw_name);
- name1[suffix - raw_name] = '\0';
- }
- else
- name1 = raw_name;
-
- bv = BLOCKVECTOR (s);
- block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
- ada_add_block_symbols (&symbol_list_obstack, block,
- name1, namespace, objfile, 0);
-
- if (num_defns_collected (&symbol_list_obstack) == ndefns0)
- {
- block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
- ada_add_block_symbols (&symbol_list_obstack, block,
- name1, namespace, objfile, 0);
- }
- }
- }
- }
- }
- }
-
- 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, 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, 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, wild_match);
- }
- }
- }
+ ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 0,
+ wild_match);
done:
ndefns = num_defns_collected (&symbol_list_obstack);
return 0;
}
-/* Return nonzero if the given string contains only digits.
- The empty string also matches. */
-
-static int
-is_digits_suffix (const char *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. */
}
}
-
/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
vector *defn_symbols, updating the list of symbols in OBSTACKP
(if necessary). If WILD, treat as NAME with a wildcard prefix.
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
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,
return sym;
}
-/* Find a type named NAME. Ignores ambiguity. */
+/* Find a type named NAME. Ignores ambiguity. This routine will look
+ solely for types defined by debug info, it will not search the GDB
+ primitive types. */
struct type *
ada_find_any_type (const char *name)
function_name = function_name + 5;
rename = (char *) alloca (rename_len * sizeof (char));
- sprintf (rename, "%s__%s___XR", function_name, name);
+ xsnprintf (rename, rename_len * sizeof (char), "%s__%s___XR",
+ function_name, name);
}
else
{
const int rename_len = strlen (name) + 6;
rename = (char *) alloca (rename_len * sizeof (char));
- sprintf (rename, "%s___XR", name);
+ xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
}
return ada_find_any_symbol (rename);
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_LENGTH (type) = 0;
else if (is_dynamic_field (type, f))
{
if (dval0 == NULL)
- dval = value_from_contents_and_address (rtype, valaddr, address);
+ {
+ /* rtype's length is computed based on the run-time
+ value of discriminants. If the discriminants are not
+ initialized, the type size may be completely bogus and
+ GDB may fail to allocate a value for it. So check the
+ size first before creating the value. */
+ check_size (rtype);
+ dval = value_from_contents_and_address (rtype, valaddr, address);
+ }
else
dval = dval0;
}
/* 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)
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));
if (real_type != NULL)
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;
+
+ xsnprintf (xvz_name, strlen (name) + 7, "%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 fixed_record_type;
}
case TYPE_CODE_ARRAY:
without consulting any runtime values. For Ada dynamic-sized
types, therefore, the type of the result is likely to be inaccurate. */
-struct value *
+static struct value *
ada_to_static_fixed_value (struct value *val)
{
struct type *type =
GROW_VECT (result, result_len, 16);
if (isascii (v) && isprint (v))
- sprintf (result, "'%c'", v);
+ xsnprintf (result, result_len, "'%c'", v);
else if (name[1] == 'U')
- sprintf (result, "[\"%02x\"]", v);
+ xsnprintf (result, result_len, "[\"%02x\"]", v);
else
- sprintf (result, "[\"%04x\"]", v);
+ xsnprintf (result, result_len, "[\"%04x\"]", v);
return result;
}
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
case BINOP_MUL:
case BINOP_DIV:
+ case BINOP_REM:
+ case BINOP_MOD:
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS
- && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
- return value_zero (value_type (arg1), not_lval);
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ return value_zero (value_type (arg1), not_lval);
+ }
else
{
type = builtin_type (exp->gdbarch)->builtin_double;
return ada_value_binop (arg1, arg2, op);
}
- case BINOP_REM:
- case BINOP_MOD:
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS
- && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
- return value_zero (value_type (arg1), not_lval);
- else
- {
- binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
- return ada_value_binop (arg1, arg2, op);
- }
-
case BINOP_EQUAL:
case BINOP_NOTEQUAL:
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
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. */
+ struct type *actual_type;
+
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
- return value_zero (type_from_tag (ada_value_tag (arg1)), not_lval);
+ actual_type = type_from_tag (ada_value_tag (arg1));
+ if (actual_type == NULL)
+ /* If, for some reason, we were unable to determine
+ the actual type from the tag, then use the static
+ approximation that we just computed as a fallback.
+ This can happen if the debugging information is
+ incomplete, for instance. */
+ actual_type = type;
+
+ return value_zero (actual_type, not_lval);
}
*pos += 4;
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)
case UNOP_IN_RANGE:
(*pos) += 2;
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- type = exp->elts[pc + 1].type;
+ type = check_typedef (exp->elts[pc + 1].type);
if (noside == EVAL_SKIP)
goto nosideret;
{
evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
arg1 = NULL;
- type_arg = exp->elts[pc + 2].type;
+ type_arg = check_typedef (exp->elts[pc + 2].type);
}
else
{
case OP_ATR_MODULUS:
{
- struct type *type_arg = exp->elts[pc + 2].type;
+ struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
if (noside == EVAL_SKIP)
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_int32, not_lval);
else
return value_from_longest (builtin_type_int32,
- TARGET_CHAR_BIT
- * TYPE_LENGTH (value_type (arg1)));
+ TARGET_CHAR_BIT * TYPE_LENGTH (type));
case OP_ATR_VAL:
evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
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 (exp->gdbarch)->builtin_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);
- else if (TYPE_CODE (type) == TYPE_CODE_INT)
- /* GDB allows dereferencing an int. */
- return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
- (CORE_ADDR) value_as_address (arg1));
else
return ada_value_ind (arg1);
ada_delta (struct type *type)
{
const char *encoding = fixed_type_info (type);
- long num, den;
+ DOUBLEST num, den;
- if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
+ /* Strictly speaking, num and den are encoded as integer. However,
+ they may not fit into a long, and they will have to be converted
+ to DOUBLEST anyway. So scan them as DOUBLEST. */
+ if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
+ &num, &den) < 2)
return -1.0;
else
- return (DOUBLEST) num / (DOUBLEST) den;
+ return num / den;
}
/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
scaling_factor (struct type *type)
{
const char *encoding = fixed_type_info (type);
- unsigned long num0, den0, num1, den1;
+ DOUBLEST num0, den0, num1, den1;
int n;
- n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
+ /* Strictly speaking, num's and den's are encoded as integer. However,
+ they may not fit into a long, and they will have to be converted
+ to DOUBLEST anyway. So scan them as DOUBLEST. */
+ n = sscanf (encoding,
+ "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
+ "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
+ &num0, &den0, &num1, &den1);
if (n < 2)
return 1.0;
else if (n == 4)
- return (DOUBLEST) num1 / (DOUBLEST) den1;
+ return num1 / den1;
else
- return (DOUBLEST) num0 / (DOUBLEST) den0;
+ return num0 / den0;
}
struct type *base_type;
char *subtype_info;
+ /* Also search primitive types if type symbol could not be found. */
+ if (raw_type == NULL)
+ raw_type = language_lookup_primitive_type_by_name
+ (language_def (language_ada), current_gdbarch, name);
+
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
&& TYPE_UNSIGNED (subranged_type));
}
+/* Try to determine the lower and upper bounds of the given modular type
+ using the type name only. Return non-zero and set L and U as the lower
+ and upper bounds (respectively) if successful. */
+
+int
+ada_modulus_from_name (struct type *type, ULONGEST *modulus)
+{
+ char *name = ada_type_name (type);
+ char *suffix;
+ int k;
+ LONGEST U;
+
+ if (name == NULL)
+ return 0;
+
+ /* Discrete type bounds are encoded using an __XD suffix. In our case,
+ we are looking for static bounds, which means an __XDLU suffix.
+ Moreover, we know that the lower bound of modular types is always
+ zero, so the actual suffix should start with "__XDLU_0__", and
+ then be followed by the upper bound value. */
+ suffix = strstr (name, "__XDLU_0__");
+ if (suffix == NULL)
+ return 0;
+ k = 10;
+ if (!ada_scan_number (suffix, k, &U, NULL))
+ return 0;
+
+ *modulus = (ULONGEST) U + 1;
+ return 1;
+}
+
/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
ULONGEST
-ada_modulus (struct type * type)
+ada_modulus (struct type *type)
{
- return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
+ ULONGEST modulus;
+
+ /* Normally, the modulus of a modular type is equal to the value of
+ its upper bound + 1. However, the upper bound is currently stored
+ as an int, which is not always big enough to hold the actual bound
+ value. To workaround this, try to take advantage of the encoding
+ that GNAT uses with with discrete types. To avoid some unnecessary
+ parsing, we do this only when the size of TYPE is greater than
+ the size of the field holding the bound. */
+ if (TYPE_LENGTH (type) > sizeof (TYPE_HIGH_BOUND (type))
+ && ada_modulus_from_name (type, &modulus))
+ return modulus;
+
+ 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
/* 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);
}
TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
= "system__address";
- lai->bool_type_symbol = "boolean";
+ lai->bool_type_symbol = NULL;
lai->bool_type_default = builtin->builtin_bool;
}
\f
/* Not really used, but needed in the ada_language_defn. */
static void
-emit_char (int c, struct ui_file *stream, int quoter)
+emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
{
- ada_emit_char (c, stream, quoter, 1);
+ ada_emit_char (c, type, stream, quoter, 1);
}
static int
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 */
ada_language_arch_info,
ada_print_array_index,
default_pass_by_reference,
+ c_get_string,
LANG_MAGIC
};
+/* Provide a prototype to silence -Wmissing-prototypes. */
+extern initialize_file_ftype _initialize_ada_language;
+
void
_initialize_ada_language (void)
{