#include "gdbsupport/function-view.h"
#include "gdbsupport/byte-vector.h"
#include <algorithm>
+#include "ada-exp.h"
/* Define whether or not the C operator '/' truncates towards zero for
differently signed operands (truncation direction is undefined in C).
static int desc_arity (struct type *);
-static int ada_type_match (struct type *, struct type *, int);
-
static int ada_args_match (struct symbol *, struct value **, int);
static struct value *make_array_descriptor (struct type *, struct value *);
struct symbol *,
const struct block *);
-static struct value *resolve_subexp (expression_up *, int *, int,
- struct type *, int,
- innermost_block_tracker *);
-
-static void replace_operator_with_call (expression_up *, int, int, int,
- struct symbol *, const struct block *);
-
static int possible_user_operator_p (enum exp_opcode, struct value **);
static const char *ada_decoded_op_name (enum exp_opcode);
static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
int, int);
-static struct value *evaluate_subexp_type (struct expression *, int *);
-
static struct type *ada_find_parallel_type_with_name (struct type *,
const char *);
static LONGEST pos_atr (struct value *);
-static struct value *value_pos_atr (struct type *, struct value *);
-
static struct value *val_atr (struct type *, LONGEST);
-static struct value *value_val_atr (struct type *, struct value *);
-
static struct symbol *standard_lookup (const char *, const struct block *,
domain_enum);
static int ada_resolve_function (std::vector<struct block_symbol> &,
struct value **, int, const char *,
- struct type *, int);
+ struct type *, bool);
static int ada_is_direct_array_type (struct type *);
static struct value *ada_index_struct_field (int, struct value *, int,
struct type *);
-static struct value *assign_aggregate (struct value *, struct value *,
- struct expression *,
- int *, enum noside);
-
-static void aggregate_assign_from_choices (struct value *, struct value *,
- struct expression *,
- int *, std::vector<LONGEST> &,
- LONGEST, LONGEST);
-
-static void aggregate_assign_positional (struct value *, struct value *,
- struct expression *,
- int *, std::vector<LONGEST> &,
- LONGEST, LONGEST);
-
-
-static void aggregate_assign_others (struct value *, struct value *,
- struct expression *,
- int *, std::vector<LONGEST> &,
- LONGEST, LONGEST);
-
-
static void add_component_interval (LONGEST, LONGEST, std::vector<LONGEST> &);
-static struct value *ada_evaluate_subexp (struct type *, struct expression *,
- int *, enum noside);
-
-static void ada_forward_operator_length (struct expression *, int, int *,
- int *);
-
static struct type *ada_find_any_type (const char *name);
static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
&& 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
- the (left-justified) packed array type we just built, we must
- first left-justify it. */
+ array with no wrapper. In order to interpret the value through
+ the (left-justified) packed array type we just built, we must
+ first left-justify it. */
int bit_size, bit_pos;
ULONGEST mod;
return NULL;
}
-/* The type of nth index in arrays of given type (n numbering from 1).
- Does not examine memory. Throws an error if N is invalid or TYPE
- is not an array type. NAME is the name of the Ada attribute being
- evaluated ('range, 'first, 'last, or 'length); it is used in building
- the error message. */
+/* See ada-lang.h. */
-static struct type *
+struct type *
ada_index_type (struct type *type, int n, const char *name)
{
struct type *result_type;
int i;
for (i = 1; i < n; i += 1)
- type = TYPE_TARGET_TYPE (type);
- result_type = TYPE_TARGET_TYPE (type->index_type ());
+ {
+ type = ada_check_typedef (type);
+ type = TYPE_TARGET_TYPE (type);
+ }
+ result_type = TYPE_TARGET_TYPE (ada_check_typedef (type)->index_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. */
return n_chosen;
}
-/* Resolve the operator of the subexpression beginning at
- position *POS of *EXPP. "Resolving" consists of replacing
- the symbols that have undefined namespaces in OP_VAR_VALUE nodes
- with their resolutions, replacing built-in operators with
- function calls to user-defined operators, where appropriate, and,
- when DEPROCEDURE_P is non-zero, converting function-valued variables
- into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
- are as in ada_resolve, above. */
+/* See ada-lang.h. */
-static struct value *
-resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
- struct type *context_type, int parse_completion,
- innermost_block_tracker *tracker)
+block_symbol
+ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
+ int nargs, value *argvec[])
{
- int pc = *pos;
- int i;
- struct expression *exp; /* Convenience: == *expp. */
- enum exp_opcode op = (*expp)->elts[pc].opcode;
- struct value **argvec; /* Vector of operand types (alloca'ed). */
- int nargs; /* Number of operands. */
- int oplen;
- /* If we're resolving an expression like ARRAY(ARG...), then we set
- this to the type of the array, so we can use the index types as
- the expected types for resolution. */
- struct type *array_type = nullptr;
- /* The arity of ARRAY_TYPE. */
- int array_arity = 0;
-
- argvec = NULL;
- nargs = 0;
- exp = expp->get ();
-
- /* Pass one: resolve operands, saving their types and updating *pos,
- if needed. */
- switch (op)
+ if (possible_user_operator_p (op, argvec))
{
- case OP_FUNCALL:
- if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
- && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
- *pos += 7;
- else
- {
- *pos += 3;
- struct value *lhs = resolve_subexp (expp, pos, 0, NULL,
- parse_completion, tracker);
- struct type *lhstype = ada_check_typedef (value_type (lhs));
- array_arity = ada_array_arity (lhstype);
- if (array_arity > 0)
- array_type = lhstype;
- }
- nargs = longest_to_int (exp->elts[pc + 1].longconst);
- break;
-
- case UNOP_ADDR:
- *pos += 1;
- resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
- break;
-
- case UNOP_QUAL:
- *pos += 3;
- resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type),
- parse_completion, tracker);
- break;
-
- case OP_ATR_MODULUS:
- case OP_ATR_SIZE:
- case OP_ATR_TAG:
- case OP_ATR_FIRST:
- case OP_ATR_LAST:
- case OP_ATR_LENGTH:
- case OP_ATR_POS:
- case OP_ATR_VAL:
- case OP_ATR_MIN:
- case OP_ATR_MAX:
- case TERNOP_IN_RANGE:
- case BINOP_IN_BOUNDS:
- case UNOP_IN_RANGE:
- case OP_AGGREGATE:
- case OP_OTHERS:
- case OP_CHOICES:
- case OP_POSITIONAL:
- case OP_DISCRETE_RANGE:
- case OP_NAME:
- ada_forward_operator_length (exp, pc, &oplen, &nargs);
- *pos += oplen;
- break;
-
- case BINOP_ASSIGN:
- {
- struct value *arg1;
-
- *pos += 1;
- arg1 = resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
- if (arg1 == NULL)
- resolve_subexp (expp, pos, 1, NULL, parse_completion, tracker);
- else
- resolve_subexp (expp, pos, 1, value_type (arg1), parse_completion,
- tracker);
- break;
- }
-
- case UNOP_CAST:
- *pos += 3;
- nargs = 1;
- break;
-
- case BINOP_ADD:
- case BINOP_SUB:
- case BINOP_MUL:
- case BINOP_DIV:
- case BINOP_REM:
- case BINOP_MOD:
- case BINOP_EXP:
- case BINOP_CONCAT:
- case BINOP_LOGICAL_AND:
- case BINOP_LOGICAL_OR:
- case BINOP_BITWISE_AND:
- case BINOP_BITWISE_IOR:
- case BINOP_BITWISE_XOR:
-
- case BINOP_EQUAL:
- case BINOP_NOTEQUAL:
- case BINOP_LESS:
- case BINOP_GTR:
- case BINOP_LEQ:
- case BINOP_GEQ:
-
- case BINOP_REPEAT:
- case BINOP_SUBSCRIPT:
- case BINOP_COMMA:
- *pos += 1;
- nargs = 2;
- break;
+ std::vector<struct block_symbol> candidates
+ = ada_lookup_symbol_list (ada_decoded_op_name (op),
+ NULL, VAR_DOMAIN);
- case UNOP_NEG:
- case UNOP_PLUS:
- case UNOP_LOGICAL_NOT:
- case UNOP_ABS:
- case UNOP_IND:
- *pos += 1;
- nargs = 1;
- break;
-
- case OP_LONG:
- case OP_FLOAT:
- case OP_VAR_VALUE:
- case OP_VAR_MSYM_VALUE:
- *pos += 4;
- break;
-
- case OP_TYPE:
- case OP_BOOL:
- case OP_LAST:
- case OP_INTERNALVAR:
- *pos += 3;
- break;
-
- case UNOP_MEMVAL:
- *pos += 3;
- nargs = 1;
- break;
-
- case OP_REGISTER:
- *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
- break;
-
- case STRUCTOP_STRUCT:
- *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
- nargs = 1;
- break;
-
- case TERNOP_SLICE:
- *pos += 1;
- nargs = 3;
- break;
+ int i = ada_resolve_function (candidates, argvec,
+ nargs, ada_decoded_op_name (op), NULL,
+ parse_completion);
+ if (i >= 0)
+ return candidates[i];
+ }
+ return {};
+}
- case OP_STRING:
- break;
+/* See ada-lang.h. */
- default:
- error (_("Unexpected operator during name resolution"));
- }
+block_symbol
+ada_resolve_funcall (struct symbol *sym, const struct block *block,
+ struct type *context_type,
+ bool parse_completion,
+ int nargs, value *argvec[],
+ innermost_block_tracker *tracker)
+{
+ std::vector<struct block_symbol> candidates
+ = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
- argvec = XALLOCAVEC (struct value *, nargs + 1);
- for (i = 0; i < nargs; i += 1)
+ int i;
+ if (candidates.size () == 1)
+ i = 0;
+ else
{
- struct type *subtype = nullptr;
- if (i < array_arity)
- subtype = ada_index_type (array_type, i + 1, "array type");
- argvec[i] = resolve_subexp (expp, pos, 1, subtype, parse_completion,
- tracker);
+ i = ada_resolve_function
+ (candidates,
+ argvec, nargs,
+ sym->linkage_name (),
+ context_type, parse_completion);
+ if (i < 0)
+ error (_("Could not find a match for %s"), sym->print_name ());
}
- argvec[i] = NULL;
- exp = expp->get ();
-
- /* Pass two: perform any resolution on principal operator. */
- switch (op)
- {
- default:
- break;
-
- case OP_VAR_VALUE:
- if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
- {
- std::vector<struct block_symbol> candidates
- = ada_lookup_symbol_list (exp->elts[pc + 2].symbol->linkage_name (),
- exp->elts[pc + 1].block, VAR_DOMAIN);
-
- if (std::any_of (candidates.begin (),
- candidates.end (),
- [] (block_symbol &sym)
- {
- switch (SYMBOL_CLASS (sym.symbol))
- {
- case LOC_REGISTER:
- case LOC_ARG:
- case LOC_REF_ARG:
- case LOC_REGPARM_ADDR:
- case LOC_LOCAL:
- case LOC_COMPUTED:
- return true;
- default:
- return false;
- }
- }))
- {
- /* Types tend to get re-introduced locally, so if there
- are any local symbols that are not types, first filter
- out all types. */
- candidates.erase
- (std::remove_if
- (candidates.begin (),
- candidates.end (),
- [] (block_symbol &sym)
- {
- return SYMBOL_CLASS (sym.symbol) == LOC_TYPEDEF;
- }),
- candidates.end ());
- }
-
- if (candidates.empty ())
- error (_("No definition found for %s"),
- exp->elts[pc + 2].symbol->print_name ());
- else if (candidates.size () == 1)
- i = 0;
- else if (deprocedure_p && !is_nonfunction (candidates))
- {
- i = ada_resolve_function
- (candidates, NULL, 0,
- exp->elts[pc + 2].symbol->linkage_name (),
- context_type, parse_completion);
- if (i < 0)
- error (_("Could not find a match for %s"),
- exp->elts[pc + 2].symbol->print_name ());
- }
- else
- {
- printf_filtered (_("Multiple matches for %s\n"),
- exp->elts[pc + 2].symbol->print_name ());
- user_select_syms (candidates.data (), candidates.size (), 1);
- i = 0;
- }
- exp->elts[pc + 1].block = candidates[i].block;
- exp->elts[pc + 2].symbol = candidates[i].symbol;
- tracker->update (candidates[i]);
- }
+ tracker->update (candidates[i]);
+ return candidates[i];
+}
- if (deprocedure_p
- && (SYMBOL_TYPE (exp->elts[pc + 2].symbol)->code ()
- == TYPE_CODE_FUNC))
- {
- replace_operator_with_call (expp, pc, 0, 4,
- exp->elts[pc + 2].symbol,
- exp->elts[pc + 1].block);
- exp = expp->get ();
- }
- break;
+/* See ada-lang.h. */
- case OP_FUNCALL:
- {
- if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
- && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
+block_symbol
+ada_resolve_variable (struct symbol *sym, const struct block *block,
+ struct type *context_type,
+ bool parse_completion,
+ int deprocedure_p,
+ innermost_block_tracker *tracker)
+{
+ std::vector<struct block_symbol> candidates
+ = ada_lookup_symbol_list (sym->linkage_name (), block, VAR_DOMAIN);
+
+ if (std::any_of (candidates.begin (),
+ candidates.end (),
+ [] (block_symbol &bsym)
+ {
+ switch (SYMBOL_CLASS (bsym.symbol))
+ {
+ case LOC_REGISTER:
+ case LOC_ARG:
+ case LOC_REF_ARG:
+ case LOC_REGPARM_ADDR:
+ case LOC_LOCAL:
+ case LOC_COMPUTED:
+ return true;
+ default:
+ return false;
+ }
+ }))
+ {
+ /* Types tend to get re-introduced locally, so if there
+ are any local symbols that are not types, first filter
+ out all types. */
+ candidates.erase
+ (std::remove_if
+ (candidates.begin (),
+ candidates.end (),
+ [] (block_symbol &bsym)
{
- std::vector<struct block_symbol> candidates
- = ada_lookup_symbol_list (exp->elts[pc + 5].symbol->linkage_name (),
- exp->elts[pc + 4].block, VAR_DOMAIN);
-
- if (candidates.size () == 1)
- i = 0;
- else
- {
- i = ada_resolve_function
- (candidates,
- argvec, nargs,
- exp->elts[pc + 5].symbol->linkage_name (),
- context_type, parse_completion);
- if (i < 0)
- error (_("Could not find a match for %s"),
- exp->elts[pc + 5].symbol->print_name ());
- }
-
- exp->elts[pc + 4].block = candidates[i].block;
- exp->elts[pc + 5].symbol = candidates[i].symbol;
- tracker->update (candidates[i]);
- }
- }
- break;
- case BINOP_ADD:
- case BINOP_SUB:
- case BINOP_MUL:
- case BINOP_DIV:
- case BINOP_REM:
- case BINOP_MOD:
- case BINOP_CONCAT:
- case BINOP_BITWISE_AND:
- case BINOP_BITWISE_IOR:
- case BINOP_BITWISE_XOR:
- case BINOP_EQUAL:
- case BINOP_NOTEQUAL:
- case BINOP_LESS:
- case BINOP_GTR:
- case BINOP_LEQ:
- case BINOP_GEQ:
- case BINOP_EXP:
- case UNOP_NEG:
- case UNOP_PLUS:
- case UNOP_LOGICAL_NOT:
- case UNOP_ABS:
- if (possible_user_operator_p (op, argvec))
- {
- std::vector<struct block_symbol> candidates
- = ada_lookup_symbol_list (ada_decoded_op_name (op),
- NULL, VAR_DOMAIN);
-
- i = ada_resolve_function (candidates, argvec,
- nargs, ada_decoded_op_name (op), NULL,
- parse_completion);
- if (i < 0)
- break;
-
- replace_operator_with_call (expp, pc, nargs, 1,
- candidates[i].symbol,
- candidates[i].block);
- exp = expp->get ();
- }
- break;
-
- case OP_TYPE:
- case OP_REGISTER:
- return NULL;
+ return SYMBOL_CLASS (bsym.symbol) == LOC_TYPEDEF;
+ }),
+ candidates.end ());
}
- *pos = pc;
- if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
- return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
- exp->elts[pc + 1].objfile,
- exp->elts[pc + 2].msymbol);
+ int i;
+ if (candidates.empty ())
+ error (_("No definition found for %s"), sym->print_name ());
+ else if (candidates.size () == 1)
+ i = 0;
+ else if (deprocedure_p && !is_nonfunction (candidates))
+ {
+ i = ada_resolve_function
+ (candidates, NULL, 0,
+ sym->linkage_name (),
+ context_type, parse_completion);
+ if (i < 0)
+ error (_("Could not find a match for %s"), sym->print_name ());
+ }
else
- return evaluate_subexp_type (exp, pos);
+ {
+ printf_filtered (_("Multiple matches for %s\n"), sym->print_name ());
+ user_select_syms (candidates.data (), candidates.size (), 1);
+ i = 0;
+ }
+
+ tracker->update (candidates[i]);
+ return candidates[i];
}
-/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
- MAY_DEREF is non-zero, the formal may be a pointer and the actual
- a non-pointer. */
+/* Return non-zero if formal type FTYPE matches actual type ATYPE. */
/* The term "match" here is rather loose. The match is heuristic and
liberal. */
static int
-ada_type_match (struct type *ftype, struct type *atype, int may_deref)
+ada_type_match (struct type *ftype, struct type *atype)
{
ftype = ada_check_typedef (ftype);
atype = ada_check_typedef (atype);
default:
return ftype->code () == atype->code ();
case TYPE_CODE_PTR:
- if (atype->code () == TYPE_CODE_PTR)
- return ada_type_match (TYPE_TARGET_TYPE (ftype),
- TYPE_TARGET_TYPE (atype), 0);
- else
- return (may_deref
- && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
+ if (atype->code () != TYPE_CODE_PTR)
+ return 0;
+ atype = TYPE_TARGET_TYPE (atype);
+ /* This can only happen if the actual argument is 'null'. */
+ if (atype->code () == TYPE_CODE_INT && TYPE_LENGTH (atype) == 0)
+ return 1;
+ return ada_type_match (TYPE_TARGET_TYPE (ftype), atype);
case TYPE_CODE_INT:
case TYPE_CODE_ENUM:
case TYPE_CODE_RANGE:
struct type *ftype = ada_check_typedef (func_type->field (i).type ());
struct type *atype = ada_check_typedef (value_type (actuals[i]));
- if (!ada_type_match (ftype, atype, 1))
+ if (!ada_type_match (ftype, atype))
return 0;
}
}
ada_resolve_function (std::vector<struct block_symbol> &syms,
struct value **args, int nargs,
const char *name, struct type *context_type,
- int parse_completion)
+ bool parse_completion)
{
int fallback;
int k;
return 0;
}
-/* Replace the operator of length OPLEN at position PC in *EXPP with a call
- on the function identified by SYM and BLOCK, and taking NARGS
- arguments. Update *EXPP as needed to hold more space. */
-
-static void
-replace_operator_with_call (expression_up *expp, int pc, int nargs,
- int oplen, struct symbol *sym,
- const struct block *block)
-{
- /* We want to add 6 more elements (3 for funcall, 4 for function
- symbol, -OPLEN for operator being replaced) to the
- expression. */
- struct expression *exp = expp->get ();
- int save_nelts = exp->nelts;
- int extra_elts = 7 - oplen;
- exp->nelts += extra_elts;
-
- if (extra_elts > 0)
- exp->resize (exp->nelts);
- memmove (exp->elts + pc + 7, exp->elts + pc + oplen,
- EXP_ELEM_TO_BYTES (save_nelts - pc - oplen));
- if (extra_elts < 0)
- exp->resize (exp->nelts);
-
- exp->elts[pc].opcode = exp->elts[pc + 2].opcode = OP_FUNCALL;
- exp->elts[pc + 1].longconst = (LONGEST) nargs;
-
- exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
- exp->elts[pc + 4].block = block;
- exp->elts[pc + 5].symbol = sym;
-}
-
/* Type-class predicates */
/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
{
case TYPE_CODE_INT:
case TYPE_CODE_FLT:
+ case TYPE_CODE_FIXED_POINT:
return 1;
case TYPE_CODE_RANGE:
return (type == TYPE_TARGET_TYPE (type)
case TYPE_CODE_RANGE:
case TYPE_CODE_ENUM:
case TYPE_CODE_FLT:
+ case TYPE_CODE_FIXED_POINT:
return 1;
default:
return 0;
add_symbols_from_enclosing_procs (result, lookup_name, domain);
}
-/* An object of this type is used as the user_data argument when
+/* An object of this type is used as the callback argument when
calling the map_matching_symbols method. */
struct match_data
}
DISABLE_COPY_AND_ASSIGN (match_data);
+ bool operator() (struct block_symbol *bsym);
+
struct objfile *objfile = nullptr;
std::vector<struct block_symbol> *resultp;
struct symbol *arg_sym = nullptr;
bool found_sym = false;
};
-/* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
- to a list of symbols. DATA is a pointer to a struct match_data *
- containing the vector that collects the symbol list, the file that SYM
- must come from, a flag indicating whether a non-argument symbol has
- been found in the current block, and the last argument symbol
- passed in SYM within the current block (if any). When SYM is null,
- marking the end of a block, the argument symbol is added if no
- other has been found. */
+/* A callback for add_nonlocal_symbols that adds symbol, found in
+ BSYM, to a list of symbols. */
-static bool
-aux_add_nonlocal_symbols (struct block_symbol *bsym,
- struct match_data *data)
+bool
+match_data::operator() (struct block_symbol *bsym)
{
const struct block *block = bsym->block;
struct symbol *sym = bsym->symbol;
if (sym == NULL)
{
- if (!data->found_sym && data->arg_sym != NULL)
- add_defn_to_vec (*data->resultp,
- fixup_symbol_section (data->arg_sym, data->objfile),
+ if (!found_sym && arg_sym != NULL)
+ add_defn_to_vec (*resultp,
+ fixup_symbol_section (arg_sym, objfile),
block);
- data->found_sym = false;
- data->arg_sym = NULL;
+ found_sym = false;
+ arg_sym = NULL;
}
else
{
if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
return true;
else if (SYMBOL_IS_ARGUMENT (sym))
- data->arg_sym = sym;
+ arg_sym = sym;
else
{
- data->found_sym = true;
- add_defn_to_vec (*data->resultp,
- fixup_symbol_section (sym, data->objfile),
+ found_sym = true;
+ add_defn_to_vec (*resultp,
+ fixup_symbol_section (sym, objfile),
block);
}
}
return lookup_name.ada ().lookup_name ().c_str ();
}
+/* A helper for add_nonlocal_symbols. Call expand_matching_symbols
+ for OBJFILE, then walk the objfile's symtabs and update the
+ results. */
+
+static void
+map_matching_symbols (struct objfile *objfile,
+ const lookup_name_info &lookup_name,
+ bool is_wild_match,
+ domain_enum domain,
+ int global,
+ match_data &data)
+{
+ data.objfile = objfile;
+ objfile->expand_matching_symbols (lookup_name, domain, global,
+ is_wild_match ? nullptr : compare_names);
+
+ const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
+ for (compunit_symtab *symtab : objfile->compunits ())
+ {
+ const struct block *block
+ = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (symtab), block_kind);
+ if (!iterate_over_symbols_terminated (block, lookup_name,
+ domain, data))
+ break;
+ }
+}
+
/* Add to RESULT all non-local symbols whose name and domain match
LOOKUP_NAME and DOMAIN respectively. The search is performed on
GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
bool is_wild_match = lookup_name.ada ().wild_match_p ();
- auto callback = [&] (struct block_symbol *bsym)
- {
- return aux_add_nonlocal_symbols (bsym, &data);
- };
-
for (objfile *objfile : current_program_space->objfiles ())
{
- data.objfile = objfile;
-
- if (objfile->sf != nullptr)
- objfile->sf->qf->map_matching_symbols (objfile, lookup_name,
- domain, global, callback,
- (is_wild_match
- ? NULL : compare_names));
+ map_matching_symbols (objfile, lookup_name, is_wild_match, domain,
+ global, data);
for (compunit_symtab *cu : objfile->compunits ())
{
lookup_name_info name1 (bracket_name, symbol_name_match_type::FULL);
for (objfile *objfile : current_program_space->objfiles ())
- {
- data.objfile = objfile;
- if (objfile->sf != nullptr)
- objfile->sf->qf->map_matching_symbols (objfile, name1,
- domain, global, callback,
- compare_names);
- }
- }
+ map_matching_symbols (objfile, name1, false, domain, global, data);
+ }
}
/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
return *result;
}
-static struct value *
-value_pos_atr (struct type *type, struct value *arg)
-{
+struct value *
+ada_pos_atr (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg)
+{
+ struct type *type = builtin_type (exp->gdbarch)->builtin_int;
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (type, not_lval);
return value_from_longest (type, pos_atr (arg));
}
return value_from_longest (type, val);
}
-static struct value *
-value_val_atr (struct type *type, struct value *arg)
+struct value *
+ada_val_atr (enum noside noside, struct type *type, struct value *arg)
{
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (type, not_lval);
+
if (!discrete_type_p (type))
error (_("'VAL only defined on discrete types"));
if (!integer_type_p (value_type (arg)))
}
}
-/* Evaluate the subexpression of EXP starting at *POS as for
- evaluate_type, updating *POS to point just past the evaluated
- expression. */
-
-static struct value *
-evaluate_subexp_type (struct expression *exp, int *pos)
-{
- return evaluate_subexp (nullptr, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
-}
-
/* If VAL is wrapped in an aligner or subtype wrapper, return the
value it wraps. */
v2 = value_as_long (arg2);
if (v2 == 0)
- error (_("second operand of %s must not be zero."), op_string (op));
+ {
+ const char *name;
+ if (op == BINOP_MOD)
+ name = "mod";
+ else if (op == BINOP_DIV)
+ name = "/";
+ else
+ {
+ gdb_assert (op == BINOP_REM);
+ name = "rem";
+ }
+
+ error (_("second operand of %s must not be zero."), name);
+ }
if (type1->is_unsigned () || op == BINOP_MOD)
return value_binop (arg1, arg2, op);
return value_equal (arg1, arg2);
}
-/* Assign the result of evaluating EXP starting at *POS to the INDEXth
- component of LHS (a simple array or a record), updating *POS past
- the expression, assuming that LHS is contained in CONTAINER. Does
- not modify the inferior's memory, nor does it modify LHS (unless
- LHS == CONTAINER). */
+namespace expr
+{
+
+bool
+check_objfile (const std::unique_ptr<ada_component> &comp,
+ struct objfile *objfile)
+{
+ return comp->uses_objfile (objfile);
+}
+
+/* Assign the result of evaluating ARG starting at *POS to the INDEXth
+ component of LHS (a simple array or a record). Does not modify the
+ inferior's memory, nor does it modify LHS (unless LHS ==
+ CONTAINER). */
static void
assign_component (struct value *container, struct value *lhs, LONGEST index,
- struct expression *exp, int *pos)
+ struct expression *exp, operation_up &arg)
{
- struct value *mark = value_mark ();
+ scoped_value_mark mark;
+
struct value *elt;
struct type *lhs_type = check_typedef (value_type (lhs));
elt = ada_to_fixed_value (elt);
}
- if (exp->elts[*pos].opcode == OP_AGGREGATE)
- assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
+ ada_aggregate_operation *ag_op
+ = dynamic_cast<ada_aggregate_operation *> (arg.get ());
+ if (ag_op != nullptr)
+ ag_op->assign_aggregate (container, elt, exp);
else
- value_assign_to_component (container, elt,
- ada_evaluate_subexp (NULL, exp, pos,
- EVAL_NORMAL));
+ value_assign_to_component (container, elt,
+ arg->evaluate (nullptr, exp,
+ EVAL_NORMAL));
+}
- value_free_to_mark (mark);
+bool
+ada_aggregate_component::uses_objfile (struct objfile *objfile)
+{
+ for (const auto &item : m_components)
+ if (item->uses_objfile (objfile))
+ return true;
+ return false;
}
-/* Assuming that LHS represents an lvalue having a record or array
- type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
- of that aggregate's value to LHS, advancing *POS past the
- aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
- lvalue containing LHS (possibly LHS itself). Does not modify
- the inferior's memory, nor does it modify the contents of
- LHS (unless == CONTAINER). Returns the modified CONTAINER. */
+void
+ada_aggregate_component::dump (ui_file *stream, int depth)
+{
+ fprintf_filtered (stream, _("%*sAggregate\n"), depth, "");
+ for (const auto &item : m_components)
+ item->dump (stream, depth + 1);
+}
-static struct value *
-assign_aggregate (struct value *container,
- struct value *lhs, struct expression *exp,
- int *pos, enum noside noside)
+void
+ada_aggregate_component::assign (struct value *container,
+ struct value *lhs, struct expression *exp,
+ std::vector<LONGEST> &indices,
+ LONGEST low, LONGEST high)
+{
+ for (auto &item : m_components)
+ item->assign (container, lhs, exp, indices, low, high);
+}
+
+/* See ada-exp.h. */
+
+value *
+ada_aggregate_operation::assign_aggregate (struct value *container,
+ struct value *lhs,
+ struct expression *exp)
{
struct type *lhs_type;
- int n = exp->elts[*pos+1].longconst;
LONGEST low_index, high_index;
- int i;
-
- *pos += 3;
- if (noside != EVAL_NORMAL)
- {
- for (i = 0; i < n; i += 1)
- ada_evaluate_subexp (NULL, exp, pos, noside);
- return container;
- }
container = ada_coerce_ref (container);
if (ada_is_direct_array_type (value_type (container)))
indices[0] = indices[1] = low_index - 1;
indices[2] = indices[3] = high_index + 1;
- for (i = 0; i < n; i += 1)
- {
- switch (exp->elts[*pos].opcode)
- {
- case OP_CHOICES:
- aggregate_assign_from_choices (container, lhs, exp, pos, indices,
- low_index, high_index);
- break;
- case OP_POSITIONAL:
- aggregate_assign_positional (container, lhs, exp, pos, indices,
- low_index, high_index);
- break;
- case OP_OTHERS:
- if (i != n-1)
- error (_("Misplaced 'others' clause"));
- aggregate_assign_others (container, lhs, exp, pos, indices,
- low_index, high_index);
- break;
- default:
- error (_("Internal error: bad aggregate clause"));
- }
- }
+ std::get<0> (m_storage)->assign (container, lhs, exp, indices,
+ low_index, high_index);
return container;
}
-
-/* Assign into the component of LHS indexed by the OP_POSITIONAL
- construct at *POS, updating *POS past the construct, given that
- the positions are relative to lower bound LOW, where HIGH is the
- upper bound. Record the position in INDICES. CONTAINER is as for
- assign_aggregate. */
-static void
-aggregate_assign_positional (struct value *container,
- struct value *lhs, struct expression *exp,
- int *pos, std::vector<LONGEST> &indices,
- LONGEST low, LONGEST high)
+
+bool
+ada_positional_component::uses_objfile (struct objfile *objfile)
{
- LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
-
- if (ind - 1 == high)
- warning (_("Extra components in aggregate ignored."));
+ return m_op->uses_objfile (objfile);
+}
+
+void
+ada_positional_component::dump (ui_file *stream, int depth)
+{
+ fprintf_filtered (stream, _("%*sPositional, index = %d\n"),
+ depth, "", m_index);
+ m_op->dump (stream, depth + 1);
+}
+
+/* Assign into the component of LHS indexed by the OP_POSITIONAL
+ construct, given that the positions are relative to lower bound
+ LOW, where HIGH is the upper bound. Record the position in
+ INDICES. CONTAINER is as for assign_aggregate. */
+void
+ada_positional_component::assign (struct value *container,
+ struct value *lhs, struct expression *exp,
+ std::vector<LONGEST> &indices,
+ LONGEST low, LONGEST high)
+{
+ LONGEST ind = m_index + low;
+
+ if (ind - 1 == high)
+ warning (_("Extra components in aggregate ignored."));
if (ind <= high)
{
add_component_interval (ind, ind, indices);
- *pos += 3;
- assign_component (container, lhs, ind, exp, pos);
+ assign_component (container, lhs, ind, exp, m_op);
}
- else
- ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
}
-/* Assign into the components of LHS indexed by the OP_CHOICES
- construct at *POS, updating *POS past the construct, given that
- the allowable indices are LOW..HIGH. Record the indices assigned
- to in INDICES. CONTAINER is as for assign_aggregate. */
-static void
-aggregate_assign_from_choices (struct value *container,
- struct value *lhs, struct expression *exp,
- int *pos, std::vector<LONGEST> &indices,
- LONGEST low, LONGEST high)
+bool
+ada_discrete_range_association::uses_objfile (struct objfile *objfile)
{
- int j;
- int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
- int choice_pos, expr_pc;
- int is_array = ada_is_direct_array_type (value_type (lhs));
+ return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile);
+}
- choice_pos = *pos += 3;
+void
+ada_discrete_range_association::dump (ui_file *stream, int depth)
+{
+ fprintf_filtered (stream, _("%*sDiscrete range:\n"), depth, "");
+ m_low->dump (stream, depth + 1);
+ m_high->dump (stream, depth + 1);
+}
- for (j = 0; j < n_choices; j += 1)
- ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
- expr_pc = *pos;
- ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
-
- for (j = 0; j < n_choices; j += 1)
+void
+ada_discrete_range_association::assign (struct value *container,
+ struct value *lhs,
+ struct expression *exp,
+ std::vector<LONGEST> &indices,
+ LONGEST low, LONGEST high,
+ operation_up &op)
+{
+ LONGEST lower = value_as_long (m_low->evaluate (nullptr, exp, EVAL_NORMAL));
+ LONGEST upper = value_as_long (m_high->evaluate (nullptr, exp, EVAL_NORMAL));
+
+ if (lower <= upper && (lower < low || upper > high))
+ error (_("Index in component association out of bounds."));
+
+ add_component_interval (lower, upper, indices);
+ while (lower <= upper)
{
- LONGEST lower, upper;
- enum exp_opcode op = exp->elts[choice_pos].opcode;
+ assign_component (container, lhs, lower, exp, op);
+ lower += 1;
+ }
+}
- if (op == OP_DISCRETE_RANGE)
- {
- choice_pos += 1;
- lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
- EVAL_NORMAL));
- upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
- EVAL_NORMAL));
- }
- else if (is_array)
- {
- lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
- EVAL_NORMAL));
- upper = lower;
- }
- else
- {
- int ind;
- const char *name;
+bool
+ada_name_association::uses_objfile (struct objfile *objfile)
+{
+ return m_val->uses_objfile (objfile);
+}
- switch (op)
- {
- case OP_NAME:
- name = &exp->elts[choice_pos + 2].string;
- break;
- case OP_VAR_VALUE:
- name = exp->elts[choice_pos + 2].symbol->natural_name ();
- break;
- default:
- error (_("Invalid record component association."));
- }
- ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
- ind = 0;
- if (! find_struct_field (name, value_type (lhs), 0,
- NULL, NULL, NULL, NULL, &ind))
- error (_("Unknown component name: %s."), name);
- lower = upper = ind;
- }
+void
+ada_name_association::dump (ui_file *stream, int depth)
+{
+ fprintf_filtered (stream, _("%*sName:\n"), depth, "");
+ m_val->dump (stream, depth + 1);
+}
- if (lower <= upper && (lower < low || upper > high))
- error (_("Index in component association out of bounds."));
+void
+ada_name_association::assign (struct value *container,
+ struct value *lhs,
+ struct expression *exp,
+ std::vector<LONGEST> &indices,
+ LONGEST low, LONGEST high,
+ operation_up &op)
+{
+ int index;
+
+ if (ada_is_direct_array_type (value_type (lhs)))
+ index = longest_to_int (value_as_long (m_val->evaluate (nullptr, exp,
+ EVAL_NORMAL)));
+ else
+ {
+ ada_string_operation *strop
+ = dynamic_cast<ada_string_operation *> (m_val.get ());
- add_component_interval (lower, upper, indices);
- while (lower <= upper)
+ const char *name;
+ if (strop != nullptr)
+ name = strop->get_name ();
+ else
{
- int pos1;
-
- pos1 = expr_pc;
- assign_component (container, lhs, lower, exp, &pos1);
- lower += 1;
+ ada_var_value_operation *vvo
+ = dynamic_cast<ada_var_value_operation *> (m_val.get ());
+ if (vvo != nullptr)
+ error (_("Invalid record component association."));
+ name = vvo->get_symbol ()->natural_name ();
}
+
+ index = 0;
+ if (! find_struct_field (name, value_type (lhs), 0,
+ NULL, NULL, NULL, NULL, &index))
+ error (_("Unknown component name: %s."), name);
}
+
+ add_component_interval (index, index, indices);
+ assign_component (container, lhs, index, exp, op);
+}
+
+bool
+ada_choices_component::uses_objfile (struct objfile *objfile)
+{
+ if (m_op->uses_objfile (objfile))
+ return true;
+ for (const auto &item : m_assocs)
+ if (item->uses_objfile (objfile))
+ return true;
+ return false;
+}
+
+void
+ada_choices_component::dump (ui_file *stream, int depth)
+{
+ fprintf_filtered (stream, _("%*sChoices:\n"), depth, "");
+ m_op->dump (stream, depth + 1);
+ for (const auto &item : m_assocs)
+ item->dump (stream, depth + 1);
+}
+
+/* Assign into the components of LHS indexed by the OP_CHOICES
+ construct at *POS, updating *POS past the construct, given that
+ the allowable indices are LOW..HIGH. Record the indices assigned
+ to in INDICES. CONTAINER is as for assign_aggregate. */
+void
+ada_choices_component::assign (struct value *container,
+ struct value *lhs, struct expression *exp,
+ std::vector<LONGEST> &indices,
+ LONGEST low, LONGEST high)
+{
+ for (auto &item : m_assocs)
+ item->assign (container, lhs, exp, indices, low, high, m_op);
+}
+
+bool
+ada_others_component::uses_objfile (struct objfile *objfile)
+{
+ return m_op->uses_objfile (objfile);
+}
+
+void
+ada_others_component::dump (ui_file *stream, int depth)
+{
+ fprintf_filtered (stream, _("%*sOthers:\n"), depth, "");
+ m_op->dump (stream, depth + 1);
}
/* Assign the value of the expression in the OP_OTHERS construct in
EXP at *POS into the components of LHS indexed from LOW .. HIGH that
have not been previously assigned. The index intervals already assigned
- are in INDICES. Updates *POS to after the OP_OTHERS clause.
- CONTAINER is as for assign_aggregate. */
-static void
-aggregate_assign_others (struct value *container,
- struct value *lhs, struct expression *exp,
- int *pos, std::vector<LONGEST> &indices,
- LONGEST low, LONGEST high)
+ are in INDICES. CONTAINER is as for assign_aggregate. */
+void
+ada_others_component::assign (struct value *container,
+ struct value *lhs, struct expression *exp,
+ std::vector<LONGEST> &indices,
+ LONGEST low, LONGEST high)
{
- int i;
- int expr_pc = *pos + 1;
-
int num_indices = indices.size ();
- for (i = 0; i < num_indices - 2; i += 2)
+ for (int i = 0; i < num_indices - 2; i += 2)
{
- LONGEST ind;
+ for (LONGEST ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
+ assign_component (container, lhs, ind, exp, m_op);
+ }
+}
- for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
- {
- int localpos;
+struct value *
+ada_assign_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
- localpos = expr_pc;
- assign_component (container, lhs, ind, exp, &localpos);
- }
+ ada_aggregate_operation *ag_op
+ = dynamic_cast<ada_aggregate_operation *> (std::get<1> (m_storage).get ());
+ if (ag_op != nullptr)
+ {
+ if (noside != EVAL_NORMAL)
+ return arg1;
+
+ arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
+ return ada_value_assign (arg1, arg1);
}
- ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
+ /* 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. */
+ struct type *type = value_type (arg1);
+ if (VALUE_LVAL (arg1) == lval_internalvar)
+ type = NULL;
+ value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return arg1;
+ if (VALUE_LVAL (arg1) == lval_internalvar)
+ {
+ /* Nothing. */
+ }
+ else
+ arg2 = coerce_for_assign (value_type (arg1), arg2);
+ return ada_value_assign (arg1, arg2);
}
+} /* namespace expr */
+
/* Add the interval [LOW .. HIGH] to the sorted set of intervals
[ INDICES[0] .. INDICES[1] ],... The resulting intervals do not
overlap. */
entity. Results in this case are unpredictable, as we usually read
past the buffer containing the data =:-o. */
-/* Evaluate a subexpression of EXP, at index *POS, and return a value
- for that subexpression cast to TO_TYPE. Advance *POS over the
- subexpression. */
-
-static value *
-ada_evaluate_subexp_for_cast (expression *exp, int *pos,
- enum noside noside, struct type *to_type)
-{
- int pc = *pos;
-
- if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
- || exp->elts[pc].opcode == OP_VAR_VALUE)
- {
- (*pos) += 4;
-
- value *val;
- if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
- {
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (to_type, not_lval);
-
- val = evaluate_var_msym_value (noside,
- exp->elts[pc + 1].objfile,
- exp->elts[pc + 2].msymbol);
- }
- else
- val = evaluate_var_value (noside,
- exp->elts[pc + 1].block,
- exp->elts[pc + 2].symbol);
-
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
-
- val = ada_value_cast (to_type, val);
-
- /* Follow the Ada language semantics that do not allow taking
- an address of the result of a cast (view conversion in Ada). */
- if (VALUE_LVAL (val) == lval_memory)
- {
- if (value_lazy (val))
- value_fetch_lazy (val);
- VALUE_LVAL (val) = not_lval;
- }
- return val;
- }
-
- value *val = evaluate_subexp (to_type, exp, pos, noside);
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- return ada_value_cast (to_type, val);
-}
-
/* A helper function for TERNOP_IN_RANGE. */
static value *
enum noside noside,
value *arg1, value *arg2, value *arg3)
{
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
-
binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
/* A helper function for UNOP_NEG. */
-static value *
+value *
ada_unop_neg (struct type *expect_type,
struct expression *exp,
enum noside noside, enum exp_opcode op,
struct value *arg1)
{
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
unop_promote (exp->language_defn, exp->gdbarch, &arg1);
return value_neg (arg1);
}
-/* Implement the evaluate_exp routine in the exp_descriptor structure
- for the Ada language. */
+/* A helper function for UNOP_IN_RANGE. */
-static struct value *
-ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
- int *pos, enum noside noside)
+value *
+ada_unop_in_range (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1, struct type *type)
{
- enum exp_opcode op;
- int tem;
- int pc;
- int preeval_pos;
- struct value *arg1 = NULL, *arg2 = NULL, *arg3;
- struct type *type;
- int nargs, oplen;
- struct value **argvec;
-
- pc = *pos;
- *pos += 1;
- op = exp->elts[pc].opcode;
-
- switch (op)
+ struct value *arg2, *arg3;
+ switch (type->code ())
{
default:
- *pos -= 1;
- arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
+ lim_warning (_("Membership test incompletely implemented; "
+ "always returns true"));
+ type = language_bool_type (exp->language_defn, exp->gdbarch);
+ return value_from_longest (type, (LONGEST) 1);
- if (noside == EVAL_NORMAL)
- arg1 = unwrap_value (arg1);
+ case TYPE_CODE_RANGE:
+ arg2 = value_from_longest (type,
+ type->bounds ()->low.const_val ());
+ arg3 = value_from_longest (type,
+ type->bounds ()->high.const_val ());
+ 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)
+ || value_equal (arg2, arg1)));
+ }
+}
- /* If evaluating an OP_FLOAT 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.
+/* A helper function for OP_ATR_TAG. */
- Similarly, we need to perform the conversion from OP_LONG
- ourselves. */
- if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
- arg1 = ada_value_cast (expect_type, arg1);
+value *
+ada_atr_tag (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1)
+{
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (ada_tag_type (arg1), not_lval);
- return arg1;
+ return ada_value_tag (arg1);
+}
- case OP_STRING:
- {
- struct value *result;
-
- *pos -= 1;
- result = evaluate_subexp_standard (expect_type, exp, pos, noside);
- /* The result type will have code OP_STRING, bashed there from
- OP_ARRAY. Bash it back. */
- if (value_type (result)->code () == TYPE_CODE_STRING)
- value_type (result)->set_code (TYPE_CODE_ARRAY);
- return result;
- }
+/* A helper function for OP_ATR_SIZE. */
- case UNOP_CAST:
- (*pos) += 2;
- type = exp->elts[pc + 1].type;
- return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
-
- case UNOP_QUAL:
- (*pos) += 2;
- type = exp->elts[pc + 1].type;
- return ada_evaluate_subexp (type, exp, pos, noside);
-
- case BINOP_ASSIGN:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (exp->elts[*pos].opcode == OP_AGGREGATE)
- {
- arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
- if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
- return arg1;
- return ada_value_assign (arg1, arg1);
- }
- /* 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 (VALUE_LVAL (arg1) == lval_internalvar)
- {
- /* Nothing. */
- }
- else
- arg2 = coerce_for_assign (value_type (arg1), arg2);
- return ada_value_assign (arg1, arg2);
+value *
+ada_atr_size (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1)
+{
+ struct type *type = value_type (arg1);
- case BINOP_ADD:
- arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
- arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- if (value_type (arg1)->code () == TYPE_CODE_PTR)
- return (value_from_longest
- (value_type (arg1),
- value_as_long (arg1) + value_as_long (arg2)));
- if (value_type (arg2)->code () == TYPE_CODE_PTR)
- return (value_from_longest
- (value_type (arg2),
- value_as_long (arg1) + value_as_long (arg2)));
- /* Preserve the original type for use by the range case below.
- 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_CODE_REF)
- type = TYPE_TARGET_TYPE (type);
- binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
- arg1 = value_binop (arg1, arg2, BINOP_ADD);
- /* We need to special-case the result of adding to a range.
- This is done for the benefit of "ptype". gdb's Ada support
- historically used the LHS to set the result type here, so
- preserve this behavior. */
- if (type->code () == TYPE_CODE_RANGE)
- arg1 = value_cast (type, arg1);
- return 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_CODE_REF)
+ type = TYPE_TARGET_TYPE (type);
- 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 (value_type (arg1)->code () == TYPE_CODE_PTR)
- return (value_from_longest
- (value_type (arg1),
- value_as_long (arg1) - value_as_long (arg2)));
- if (value_type (arg2)->code () == TYPE_CODE_PTR)
- return (value_from_longest
- (value_type (arg2),
- value_as_long (arg1) - value_as_long (arg2)));
- /* Preserve the original type for use by the range case below.
- 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_CODE_REF)
- type = TYPE_TARGET_TYPE (type);
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
+ else
+ return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
+ TARGET_CHAR_BIT * TYPE_LENGTH (type));
+}
+
+/* A helper function for UNOP_ABS. */
+
+value *
+ada_abs (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1)
+{
+ 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;
+}
+
+/* A helper function for BINOP_MUL. */
+
+value *
+ada_mult_binop (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1, struct value *arg2)
+{
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ return value_zero (value_type (arg1), not_lval);
+ }
+ else
+ {
binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
- arg1 = value_binop (arg1, arg2, BINOP_SUB);
- /* We need to special-case the result of adding to a range.
- This is done for the benefit of "ptype". gdb's Ada support
- historically used the LHS to set the result type here, so
- preserve this behavior. */
- if (type->code () == TYPE_CODE_RANGE)
- arg1 = value_cast (type, arg1);
- return arg1;
+ return ada_value_binop (arg1, arg2, op);
+ }
+}
- case BINOP_MUL:
- case BINOP_DIV:
- case BINOP_REM:
- case BINOP_MOD:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- 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;
- binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
- return ada_value_binop (arg1, arg2, op);
- }
+/* A helper function for BINOP_EQUAL and BINOP_NOTEQUAL. */
- case BINOP_EQUAL:
- case BINOP_NOTEQUAL:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- tem = 0;
+value *
+ada_equal_binop (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1, struct value *arg2)
+{
+ int tem;
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ tem = 0;
+ else
+ {
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ tem = ada_value_equal (arg1, arg2);
+ }
+ if (op == BINOP_NOTEQUAL)
+ tem = !tem;
+ struct type *type = language_bool_type (exp->language_defn, exp->gdbarch);
+ return value_from_longest (type, (LONGEST) tem);
+}
+
+/* A helper function for TERNOP_SLICE. */
+
+value *
+ada_ternop_slice (struct expression *exp,
+ enum noside noside,
+ struct value *array, struct value *low_bound_val,
+ struct value *high_bound_val)
+{
+ LONGEST low_bound;
+ LONGEST high_bound;
+
+ low_bound_val = coerce_ref (low_bound_val);
+ high_bound_val = coerce_ref (high_bound_val);
+ low_bound = value_as_long (low_bound_val);
+ high_bound = value_as_long (high_bound_val);
+
+ /* If this is a reference to an aligner type, then remove all
+ the aligners. */
+ if (value_type (array)->code () == TYPE_CODE_REF
+ && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
+ TYPE_TARGET_TYPE (value_type (array)) =
+ ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
+
+ if (ada_is_any_packed_array_type (value_type (array)))
+ error (_("cannot slice a packed array"));
+
+ /* If this is a reference to an array or an array lvalue,
+ convert to a pointer. */
+ if (value_type (array)->code () == TYPE_CODE_REF
+ || (value_type (array)->code () == TYPE_CODE_ARRAY
+ && VALUE_LVAL (array) == lval_memory))
+ array = value_addr (array);
+
+ if (noside == EVAL_AVOID_SIDE_EFFECTS
+ && ada_is_array_descriptor_type (ada_check_typedef
+ (value_type (array))))
+ return empty_array (ada_type_of_array (array, 0), low_bound,
+ high_bound);
+
+ array = ada_coerce_to_simple_array_ptr (array);
+
+ /* If we have more than one level of pointer indirection,
+ dereference the value until we get only one level. */
+ while (value_type (array)->code () == TYPE_CODE_PTR
+ && (TYPE_TARGET_TYPE (value_type (array))->code ()
+ == TYPE_CODE_PTR))
+ array = value_ind (array);
+
+ /* Make sure we really do have an array type before going further,
+ to avoid a SEGV when trying to get the index type or the target
+ type later down the road if the debug info generated by
+ the compiler is incorrect or incomplete. */
+ if (!ada_is_simple_array_type (value_type (array)))
+ error (_("cannot take slice of non-array"));
+
+ if (ada_check_typedef (value_type (array))->code ()
+ == TYPE_CODE_PTR)
+ {
+ struct type *type0 = ada_check_typedef (value_type (array));
+
+ if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
+ return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
else
{
- binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
- tem = ada_value_equal (arg1, arg2);
+ struct type *arr_type0 =
+ to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
+
+ return ada_value_slice_from_ptr (array, arr_type0,
+ longest_to_int (low_bound),
+ longest_to_int (high_bound));
}
- if (op == BINOP_NOTEQUAL)
- tem = !tem;
- type = language_bool_type (exp->language_defn, exp->gdbarch);
- return value_from_longest (type, (LONGEST) tem);
+ }
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return array;
+ else if (high_bound < low_bound)
+ return empty_array (value_type (array), low_bound, high_bound);
+ else
+ return ada_value_slice (array, longest_to_int (low_bound),
+ longest_to_int (high_bound));
+}
- case UNOP_NEG:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- return ada_unop_neg (expect_type, exp, noside, op, arg1);
+/* A helper function for BINOP_IN_BOUNDS. */
- case BINOP_LOGICAL_AND:
- case BINOP_LOGICAL_OR:
- case UNOP_LOGICAL_NOT:
- {
- struct value *val;
+value *
+ada_binop_in_bounds (struct expression *exp, enum noside noside,
+ struct value *arg1, struct value *arg2, int n)
+{
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ struct type *type = language_bool_type (exp->language_defn,
+ exp->gdbarch);
+ return value_zero (type, not_lval);
+ }
- *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);
- }
+ struct type *type = ada_index_type (value_type (arg2), n, "range");
+ if (!type)
+ type = value_type (arg1);
- case BINOP_BITWISE_AND:
- case BINOP_BITWISE_IOR:
- case BINOP_BITWISE_XOR:
- {
- struct value *val;
-
- arg1 = evaluate_subexp (nullptr, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
- *pos = pc;
- val = evaluate_subexp_standard (expect_type, exp, pos, noside);
+ value *arg3 = value_from_longest (type, ada_array_bound (arg2, n, 1));
+ arg2 = value_from_longest (type, ada_array_bound (arg2, n, 0));
- return value_cast (value_type (arg1), val);
- }
+ 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)
+ || value_equal (arg2, arg1)));
+}
- case OP_VAR_VALUE:
- *pos -= 1;
+/* A helper function for some attribute operations. */
- if (noside == EVAL_SKIP)
- {
- *pos += 4;
- goto nosideret;
- }
+static value *
+ada_unop_atr (struct expression *exp, enum noside noside, enum exp_opcode op,
+ struct value *arg1, struct type *type_arg, int tem)
+{
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ if (type_arg == NULL)
+ type_arg = value_type (arg1);
- if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
- /* Only encountered when an unresolved symbol occurs in a
- context other than a function call, in which case, it is
- invalid. */
- error (_("Unexpected unresolved symbol, %s, during evaluation"),
- exp->elts[pc + 2].symbol->print_name ());
+ if (ada_is_constrained_packed_array_type (type_arg))
+ type_arg = decode_constrained_packed_array_type (type_arg);
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ if (!discrete_type_p (type_arg))
{
- type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
- /* Check to see if this is a tagged type. We also need to handle
- the case where the type is a reference to a tagged type, but
- we have to be careful to exclude pointers to tagged types.
- The latter should be shown as usual (as a pointer), whereas
- a reference should mostly be transparent to the user. */
- if (ada_is_tagged_type (type, 0)
- || (type->code () == TYPE_CODE_REF
- && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
- {
- /* Tagged types are a little special in the fact that the real
- type is dynamic and can only be determined by inspecting the
- object's tag. This means that we need to get the object's
- value first (EVAL_NORMAL) and then extract the actual object
- type from its tag.
-
- Note that we cannot skip the final step where we extract
- the object type from its tag, because the EVAL_NORMAL phase
- results in dynamic components being resolved into fixed ones.
- This can cause problems when trying to print the type
- description of tagged types whose parent has a dynamic size:
- We use the type name of the "_parent" component in order
- to print the name of the ancestor type in the type description.
- If that component had a dynamic size, the resolution into
- a fixed type would result in the loss of that type name,
- thus preventing us from printing the name of the ancestor
- type in the type description. */
- arg1 = evaluate_subexp (nullptr, exp, pos, EVAL_NORMAL);
-
- if (type->code () != TYPE_CODE_REF)
- {
- struct type *actual_type;
-
- actual_type = type_from_tag (ada_value_tag (arg1));
- if (actual_type == NULL)
- /* If, for some reason, we were unable to determine
- the actual type from the tag, then use the static
- approximation that we just computed as a fallback.
- This can happen if the debugging information is
- incomplete, for instance. */
- actual_type = type;
- return value_zero (actual_type, not_lval);
- }
- else
- {
- /* In the case of a ref, ada_coerce_ref takes care
- of determining the actual type. But the evaluation
- should return a ref as it should be valid to ask
- for its address; so rebuild a ref after coerce. */
- arg1 = ada_coerce_ref (arg1);
- return value_ref (arg1, TYPE_CODE_REF);
- }
- }
-
- /* Records and unions for which GNAT encodings have been
- generated need to be statically fixed as well.
- Otherwise, non-static fixing produces a type where
- all dynamic properties are removed, which prevents "ptype"
- from being able to completely describe the type.
- For instance, a case statement in a variant record would be
- replaced by the relevant components based on the actual
- value of the discriminants. */
- if ((type->code () == TYPE_CODE_STRUCT
- && dynamic_template_type (type) != NULL)
- || (type->code () == TYPE_CODE_UNION
- && ada_find_parallel_type (type, "___XVU") != NULL))
+ switch (op)
{
- *pos += 4;
- return value_zero (to_static_fixed_type (type), not_lval);
+ default: /* Should never happen. */
+ error (_("unexpected attribute encountered"));
+ case OP_ATR_FIRST:
+ case OP_ATR_LAST:
+ type_arg = ada_index_type (type_arg, tem,
+ ada_attribute_name (op));
+ break;
+ case OP_ATR_LENGTH:
+ type_arg = builtin_type (exp->gdbarch)->builtin_int;
+ break;
}
}
- arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
- return ada_to_fixed_value (arg1);
-
- case OP_FUNCALL:
- (*pos) += 2;
+ return value_zero (type_arg, not_lval);
+ }
+ else if (type_arg == NULL)
+ {
+ arg1 = ada_coerce_ref (arg1);
- /* Allocate arg vector, including space for the function to be
- called in argvec[0] and a terminating NULL. */
- nargs = longest_to_int (exp->elts[pc + 1].longconst);
- argvec = XALLOCAVEC (struct value *, nargs + 2);
+ if (ada_is_constrained_packed_array_type (value_type (arg1)))
+ arg1 = ada_coerce_to_simple_array (arg1);
- if (exp->elts[*pos].opcode == OP_VAR_VALUE
- && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
- error (_("Unexpected unresolved symbol, %s, during evaluation"),
- exp->elts[pc + 5].symbol->print_name ());
+ struct type *type;
+ if (op == OP_ATR_LENGTH)
+ type = builtin_type (exp->gdbarch)->builtin_int;
else
{
- for (tem = 0; tem <= nargs; tem += 1)
- argvec[tem] = evaluate_subexp (nullptr, exp, pos, noside);
- argvec[tem] = 0;
-
- if (noside == EVAL_SKIP)
- goto nosideret;
+ type = ada_index_type (value_type (arg1), tem,
+ ada_attribute_name (op));
+ if (type == NULL)
+ type = builtin_type (exp->gdbarch)->builtin_int;
}
- if (ada_is_constrained_packed_array_type
- (desc_base_type (value_type (argvec[0]))))
- argvec[0] = ada_coerce_to_simple_array (argvec[0]);
- else if (value_type (argvec[0])->code () == TYPE_CODE_ARRAY
- && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
- /* This is a packed array that has already been fixed, and
- therefore already coerced to a simple array. Nothing further
- to do. */
- ;
- else if (value_type (argvec[0])->code () == TYPE_CODE_REF)
+ switch (op)
{
- /* Make sure we dereference references so that all the code below
- feels like it's really handling the referenced value. Wrapping
- types (for alignment) may be there, so make sure we strip them as
- well. */
- argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
+ default: /* Should never happen. */
+ error (_("unexpected attribute encountered"));
+ case OP_ATR_FIRST:
+ return value_from_longest
+ (type, ada_array_bound (arg1, tem, 0));
+ case OP_ATR_LAST:
+ return value_from_longest
+ (type, ada_array_bound (arg1, tem, 1));
+ case OP_ATR_LENGTH:
+ return value_from_longest
+ (type, ada_array_length (arg1, tem));
}
- else if (value_type (argvec[0])->code () == TYPE_CODE_ARRAY
- && VALUE_LVAL (argvec[0]) == lval_memory)
- argvec[0] = value_addr (argvec[0]);
+ }
+ else if (discrete_type_p (type_arg))
+ {
+ struct type *range_type;
+ const char *name = ada_type_name (type_arg);
- type = ada_check_typedef (value_type (argvec[0]));
+ range_type = NULL;
+ if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
+ range_type = to_fixed_range_type (type_arg, NULL);
+ if (range_type == NULL)
+ range_type = type_arg;
+ switch (op)
+ {
+ default:
+ error (_("unexpected attribute encountered"));
+ case OP_ATR_FIRST:
+ return value_from_longest
+ (range_type, ada_discrete_type_low_bound (range_type));
+ case OP_ATR_LAST:
+ return value_from_longest
+ (range_type, ada_discrete_type_high_bound (range_type));
+ case OP_ATR_LENGTH:
+ error (_("the 'length attribute applies only to array types"));
+ }
+ }
+ else if (type_arg->code () == TYPE_CODE_FLT)
+ error (_("unimplemented type attribute"));
+ else
+ {
+ LONGEST low, high;
- /* Ada allows us to implicitly dereference arrays when subscripting
- them. So, if this is an array typedef (encoding use for array
- access types encoded as fat pointers), strip it now. */
- if (type->code () == TYPE_CODE_TYPEDEF)
- type = ada_typedef_target_type (type);
+ if (ada_is_constrained_packed_array_type (type_arg))
+ type_arg = decode_constrained_packed_array_type (type_arg);
- if (type->code () == TYPE_CODE_PTR)
+ struct type *type;
+ if (op == OP_ATR_LENGTH)
+ type = builtin_type (exp->gdbarch)->builtin_int;
+ else
{
- switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
- {
- case TYPE_CODE_FUNC:
- type = ada_check_typedef (TYPE_TARGET_TYPE (type));
- break;
- case TYPE_CODE_ARRAY:
- break;
- case TYPE_CODE_STRUCT:
- if (noside != EVAL_AVOID_SIDE_EFFECTS)
- argvec[0] = ada_value_ind (argvec[0]);
- type = ada_check_typedef (TYPE_TARGET_TYPE (type));
- break;
- default:
- error (_("cannot subscript or call something of type `%s'"),
- ada_type_name (value_type (argvec[0])));
- break;
- }
+ type = ada_index_type (type_arg, tem, ada_attribute_name (op));
+ if (type == NULL)
+ type = builtin_type (exp->gdbarch)->builtin_int;
}
- switch (type->code ())
+ switch (op)
{
- case TYPE_CODE_FUNC:
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- if (TYPE_TARGET_TYPE (type) == NULL)
- error_call_unknown_return_type (NULL);
- return allocate_value (TYPE_TARGET_TYPE (type));
- }
- return call_function_by_hand (argvec[0], NULL,
- gdb::make_array_view (argvec + 1,
- nargs));
- case TYPE_CODE_INTERNAL_FUNCTION:
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- /* We don't know anything about what the internal
- function might return, but we have to return
- something. */
- return value_zero (builtin_type (exp->gdbarch)->builtin_int,
- not_lval);
- else
- return call_internal_function (exp->gdbarch, exp->language_defn,
- argvec[0], nargs, argvec + 1);
-
- case TYPE_CODE_STRUCT:
- {
- int arity;
-
- arity = ada_array_arity (type);
- type = ada_array_element_type (type, nargs);
- if (type == NULL)
- error (_("cannot subscript or call a record"));
- if (arity != nargs)
- error (_("wrong number of subscripts; expecting %d"), arity);
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (ada_aligned_type (type), lval_memory);
- return
- unwrap_value (ada_value_subscript
- (argvec[0], nargs, argvec + 1));
- }
- case TYPE_CODE_ARRAY:
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- type = ada_array_element_type (type, nargs);
- if (type == NULL)
- error (_("element type of array unknown"));
- else
- return value_zero (ada_aligned_type (type), lval_memory);
- }
- return
- unwrap_value (ada_value_subscript
- (ada_coerce_to_simple_array (argvec[0]),
- nargs, argvec + 1));
- case TYPE_CODE_PTR: /* Pointer to array */
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
- type = ada_array_element_type (type, nargs);
- if (type == NULL)
- error (_("element type of array unknown"));
- else
- return value_zero (ada_aligned_type (type), lval_memory);
- }
- return
- unwrap_value (ada_value_ptr_subscript (argvec[0],
- nargs, argvec + 1));
-
default:
- error (_("Attempt to index or call something other than an "
- "array or function"));
+ error (_("unexpected attribute encountered"));
+ case OP_ATR_FIRST:
+ low = ada_array_bound_from_type (type_arg, tem, 0);
+ return value_from_longest (type, low);
+ case OP_ATR_LAST:
+ high = ada_array_bound_from_type (type_arg, tem, 1);
+ return value_from_longest (type, high);
+ case OP_ATR_LENGTH:
+ low = ada_array_bound_from_type (type_arg, tem, 0);
+ high = ada_array_bound_from_type (type_arg, tem, 1);
+ return value_from_longest (type, high - low + 1);
}
+ }
+}
- case TERNOP_SLICE:
- {
- struct value *array = evaluate_subexp (nullptr, exp, pos, noside);
- struct value *low_bound_val
- = evaluate_subexp (nullptr, exp, pos, noside);
- struct value *high_bound_val
- = evaluate_subexp (nullptr, exp, pos, noside);
- LONGEST low_bound;
- LONGEST high_bound;
-
- low_bound_val = coerce_ref (low_bound_val);
- high_bound_val = coerce_ref (high_bound_val);
- low_bound = value_as_long (low_bound_val);
- high_bound = value_as_long (high_bound_val);
-
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- /* If this is a reference to an aligner type, then remove all
- the aligners. */
- if (value_type (array)->code () == TYPE_CODE_REF
- && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
- TYPE_TARGET_TYPE (value_type (array)) =
- ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
-
- if (ada_is_any_packed_array_type (value_type (array)))
- error (_("cannot slice a packed array"));
-
- /* If this is a reference to an array or an array lvalue,
- convert to a pointer. */
- if (value_type (array)->code () == TYPE_CODE_REF
- || (value_type (array)->code () == TYPE_CODE_ARRAY
- && VALUE_LVAL (array) == lval_memory))
- array = value_addr (array);
-
- if (noside == EVAL_AVOID_SIDE_EFFECTS
- && ada_is_array_descriptor_type (ada_check_typedef
- (value_type (array))))
- return empty_array (ada_type_of_array (array, 0), low_bound,
- high_bound);
-
- array = ada_coerce_to_simple_array_ptr (array);
-
- /* If we have more than one level of pointer indirection,
- dereference the value until we get only one level. */
- while (value_type (array)->code () == TYPE_CODE_PTR
- && (TYPE_TARGET_TYPE (value_type (array))->code ()
- == TYPE_CODE_PTR))
- array = value_ind (array);
-
- /* Make sure we really do have an array type before going further,
- to avoid a SEGV when trying to get the index type or the target
- type later down the road if the debug info generated by
- the compiler is incorrect or incomplete. */
- if (!ada_is_simple_array_type (value_type (array)))
- error (_("cannot take slice of non-array"));
-
- if (ada_check_typedef (value_type (array))->code ()
- == TYPE_CODE_PTR)
- {
- struct type *type0 = ada_check_typedef (value_type (array));
+/* A helper function for OP_ATR_MIN and OP_ATR_MAX. */
- if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
- return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
- else
- {
- struct type *arr_type0 =
- to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
+struct value *
+ada_binop_minmax (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1, struct value *arg2)
+{
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (value_type (arg1), not_lval);
+ else
+ {
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ return value_binop (arg1, arg2, op);
+ }
+}
- 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)
- return array;
- else if (high_bound < low_bound)
- return empty_array (value_type (array), low_bound, high_bound);
- else
- return ada_value_slice (array, longest_to_int (low_bound),
- longest_to_int (high_bound));
- }
+/* A helper function for BINOP_EXP. */
- case UNOP_IN_RANGE:
- (*pos) += 2;
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- type = check_typedef (exp->elts[pc + 1].type);
+struct value *
+ada_binop_exp (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1, struct value *arg2)
+{
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (value_type (arg1), not_lval);
+ else
+ {
+ /* 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);
- if (noside == EVAL_SKIP)
- goto nosideret;
+ return value_binop (arg1, arg2, op);
+ }
+}
- switch (type->code ())
- {
- default:
- lim_warning (_("Membership test incompletely implemented; "
- "always returns true"));
- type = language_bool_type (exp->language_defn, exp->gdbarch);
- return value_from_longest (type, (LONGEST) 1);
+namespace expr
+{
- case TYPE_CODE_RANGE:
- arg2 = value_from_longest (type,
- type->bounds ()->low.const_val ());
- arg3 = value_from_longest (type,
- type->bounds ()->high.const_val ());
- 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)
- || value_equal (arg2, arg1)));
- }
-
- case BINOP_IN_BOUNDS:
- (*pos) += 2;
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (nullptr, exp, pos, noside);
-
- if (noside == EVAL_SKIP)
- goto nosideret;
+value *
+ada_wrapped_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *result = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
+ if (noside == EVAL_NORMAL)
+ result = unwrap_value (result);
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- type = language_bool_type (exp->language_defn, exp->gdbarch);
- return value_zero (type, not_lval);
- }
+ /* If evaluating an OP_FLOAT 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.
- tem = longest_to_int (exp->elts[pc + 1].longconst);
+ Similarly, we need to perform the conversion from OP_LONG
+ ourselves. */
+ if ((opcode () == OP_FLOAT || opcode () == OP_LONG) && expect_type != NULL)
+ result = ada_value_cast (expect_type, result);
- type = ada_index_type (value_type (arg2), tem, "range");
- if (!type)
- type = value_type (arg1);
+ return result;
+}
- arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
- arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
+value *
+ada_string_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *result = string_operation::evaluate (expect_type, exp, noside);
+ /* The result type will have code OP_STRING, bashed there from
+ OP_ARRAY. Bash it back. */
+ if (value_type (result)->code () == TYPE_CODE_STRING)
+ value_type (result)->set_code (TYPE_CODE_ARRAY);
+ return result;
+}
- 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)
- || value_equal (arg2, arg1)));
+value *
+ada_qual_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ struct type *type = std::get<1> (m_storage);
+ return std::get<0> (m_storage)->evaluate (type, exp, noside);
+}
+
+value *
+ada_ternop_range_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *arg0 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
+ value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
+ value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
+ return eval_ternop_in_range (expect_type, exp, noside, arg0, arg1, arg2);
+}
- case TERNOP_IN_RANGE:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (nullptr, exp, pos, noside);
- arg3 = evaluate_subexp (nullptr, exp, pos, noside);
+value *
+ada_binop_addsub_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *arg1 = std::get<1> (m_storage)->evaluate_with_coercion (exp, noside);
+ value *arg2 = std::get<2> (m_storage)->evaluate_with_coercion (exp, noside);
- return eval_ternop_in_range (expect_type, exp, noside, arg1, arg2, arg3);
+ auto do_op = [=] (LONGEST x, LONGEST y)
+ {
+ if (std::get<0> (m_storage) == BINOP_ADD)
+ return x + y;
+ return x - y;
+ };
- case OP_ATR_FIRST:
- case OP_ATR_LAST:
- case OP_ATR_LENGTH:
- {
- struct type *type_arg;
+ if (value_type (arg1)->code () == TYPE_CODE_PTR)
+ return (value_from_longest
+ (value_type (arg1),
+ do_op (value_as_long (arg1), value_as_long (arg2))));
+ if (value_type (arg2)->code () == TYPE_CODE_PTR)
+ return (value_from_longest
+ (value_type (arg2),
+ do_op (value_as_long (arg1), value_as_long (arg2))));
+ /* Preserve the original type for use by the range case below.
+ We cannot cast the result to a reference type, so if ARG1 is
+ a reference type, find its underlying type. */
+ struct type *type = value_type (arg1);
+ while (type->code () == TYPE_CODE_REF)
+ type = TYPE_TARGET_TYPE (type);
+ binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+ arg1 = value_binop (arg1, arg2, std::get<0> (m_storage));
+ /* We need to special-case the result with a range.
+ This is done for the benefit of "ptype". gdb's Ada support
+ historically used the LHS to set the result type here, so
+ preserve this behavior. */
+ if (type->code () == TYPE_CODE_RANGE)
+ arg1 = value_cast (type, arg1);
+ return arg1;
+}
- if (exp->elts[*pos].opcode == OP_TYPE)
- {
- evaluate_subexp (nullptr, exp, pos, EVAL_SKIP);
- arg1 = NULL;
- type_arg = check_typedef (exp->elts[pc + 2].type);
- }
- else
- {
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- type_arg = NULL;
- }
+value *
+ada_unop_atr_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ struct type *type_arg = nullptr;
+ value *val = nullptr;
- if (exp->elts[*pos].opcode != OP_LONG)
- error (_("Invalid operand to '%s"), ada_attribute_name (op));
- tem = longest_to_int (exp->elts[*pos + 2].longconst);
- *pos += 4;
+ if (std::get<0> (m_storage)->opcode () == OP_TYPE)
+ {
+ value *tem = std::get<0> (m_storage)->evaluate (nullptr, exp,
+ EVAL_AVOID_SIDE_EFFECTS);
+ type_arg = value_type (tem);
+ }
+ else
+ val = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- if (type_arg == NULL)
- type_arg = value_type (arg1);
+ return ada_unop_atr (exp, noside, std::get<1> (m_storage),
+ val, type_arg, std::get<2> (m_storage));
+}
- if (ada_is_constrained_packed_array_type (type_arg))
- type_arg = decode_constrained_packed_array_type (type_arg);
+value *
+ada_var_msym_value_operation::evaluate_for_cast (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (expect_type, not_lval);
- if (!discrete_type_p (type_arg))
- {
- switch (op)
- {
- default: /* Should never happen. */
- error (_("unexpected attribute encountered"));
- case OP_ATR_FIRST:
- case OP_ATR_LAST:
- type_arg = ada_index_type (type_arg, tem,
- ada_attribute_name (op));
- break;
- case OP_ATR_LENGTH:
- type_arg = builtin_type (exp->gdbarch)->builtin_int;
- break;
- }
- }
+ const bound_minimal_symbol &b = std::get<0> (m_storage);
+ value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
- return value_zero (type_arg, not_lval);
- }
- else if (type_arg == NULL)
- {
- arg1 = ada_coerce_ref (arg1);
+ val = ada_value_cast (expect_type, val);
- if (ada_is_constrained_packed_array_type (value_type (arg1)))
- arg1 = ada_coerce_to_simple_array (arg1);
+ /* Follow the Ada language semantics that do not allow taking
+ an address of the result of a cast (view conversion in Ada). */
+ if (VALUE_LVAL (val) == lval_memory)
+ {
+ if (value_lazy (val))
+ value_fetch_lazy (val);
+ VALUE_LVAL (val) = not_lval;
+ }
+ return val;
+}
- if (op == OP_ATR_LENGTH)
- type = builtin_type (exp->gdbarch)->builtin_int;
- else
- {
- type = ada_index_type (value_type (arg1), tem,
- ada_attribute_name (op));
- if (type == NULL)
- type = builtin_type (exp->gdbarch)->builtin_int;
- }
+value *
+ada_var_value_operation::evaluate_for_cast (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *val = evaluate_var_value (noside,
+ std::get<0> (m_storage).block,
+ std::get<0> (m_storage).symbol);
- switch (op)
- {
- default: /* Should never happen. */
- error (_("unexpected attribute encountered"));
- case OP_ATR_FIRST:
- return value_from_longest
- (type, ada_array_bound (arg1, tem, 0));
- case OP_ATR_LAST:
- return value_from_longest
- (type, ada_array_bound (arg1, tem, 1));
- case OP_ATR_LENGTH:
- return value_from_longest
- (type, ada_array_length (arg1, tem));
- }
- }
- else if (discrete_type_p (type_arg))
- {
- struct type *range_type;
- const char *name = ada_type_name (type_arg);
-
- range_type = NULL;
- if (name != NULL && type_arg->code () != TYPE_CODE_ENUM)
- range_type = to_fixed_range_type (type_arg, NULL);
- if (range_type == NULL)
- range_type = type_arg;
- switch (op)
- {
- default:
- error (_("unexpected attribute encountered"));
- case OP_ATR_FIRST:
- return value_from_longest
- (range_type, ada_discrete_type_low_bound (range_type));
- case OP_ATR_LAST:
- return value_from_longest
- (range_type, ada_discrete_type_high_bound (range_type));
- case OP_ATR_LENGTH:
- error (_("the 'length attribute applies only to array types"));
- }
- }
- else if (type_arg->code () == TYPE_CODE_FLT)
- error (_("unimplemented type attribute"));
- else
- {
- LONGEST low, high;
+ val = ada_value_cast (expect_type, val);
- if (ada_is_constrained_packed_array_type (type_arg))
- type_arg = decode_constrained_packed_array_type (type_arg);
+ /* Follow the Ada language semantics that do not allow taking
+ an address of the result of a cast (view conversion in Ada). */
+ if (VALUE_LVAL (val) == lval_memory)
+ {
+ if (value_lazy (val))
+ value_fetch_lazy (val);
+ VALUE_LVAL (val) = not_lval;
+ }
+ return val;
+}
- if (op == OP_ATR_LENGTH)
- type = builtin_type (exp->gdbarch)->builtin_int;
- else
- {
- type = ada_index_type (type_arg, tem, ada_attribute_name (op));
- if (type == NULL)
- type = builtin_type (exp->gdbarch)->builtin_int;
- }
+value *
+ada_var_value_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ symbol *sym = std::get<0> (m_storage).symbol;
- switch (op)
- {
- default:
- error (_("unexpected attribute encountered"));
- case OP_ATR_FIRST:
- low = ada_array_bound_from_type (type_arg, tem, 0);
- return value_from_longest (type, low);
- case OP_ATR_LAST:
- high = ada_array_bound_from_type (type_arg, tem, 1);
- return value_from_longest (type, high);
- case OP_ATR_LENGTH:
- low = ada_array_bound_from_type (type_arg, tem, 0);
- high = ada_array_bound_from_type (type_arg, tem, 1);
- return value_from_longest (type, high - low + 1);
- }
- }
- }
+ if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
+ /* Only encountered when an unresolved symbol occurs in a
+ context other than a function call, in which case, it is
+ invalid. */
+ error (_("Unexpected unresolved symbol, %s, during evaluation"),
+ sym->print_name ());
- case OP_ATR_TAG:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ struct type *type = static_unwrap_type (SYMBOL_TYPE (sym));
+ /* Check to see if this is a tagged type. We also need to handle
+ the case where the type is a reference to a tagged type, but
+ we have to be careful to exclude pointers to tagged types.
+ The latter should be shown as usual (as a pointer), whereas
+ a reference should mostly be transparent to the user. */
+ if (ada_is_tagged_type (type, 0)
+ || (type->code () == TYPE_CODE_REF
+ && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
+ {
+ /* Tagged types are a little special in the fact that the real
+ type is dynamic and can only be determined by inspecting the
+ object's tag. This means that we need to get the object's
+ value first (EVAL_NORMAL) and then extract the actual object
+ type from its tag.
+
+ Note that we cannot skip the final step where we extract
+ the object type from its tag, because the EVAL_NORMAL phase
+ results in dynamic components being resolved into fixed ones.
+ This can cause problems when trying to print the type
+ description of tagged types whose parent has a dynamic size:
+ We use the type name of the "_parent" component in order
+ to print the name of the ancestor type in the type description.
+ If that component had a dynamic size, the resolution into
+ a fixed type would result in the loss of that type name,
+ thus preventing us from printing the name of the ancestor
+ type in the type description. */
+ value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
+
+ if (type->code () != TYPE_CODE_REF)
+ {
+ struct type *actual_type;
+
+ actual_type = type_from_tag (ada_value_tag (arg1));
+ if (actual_type == NULL)
+ /* If, for some reason, we were unable to determine
+ the actual type from the tag, then use the static
+ approximation that we just computed as a fallback.
+ This can happen if the debugging information is
+ incomplete, for instance. */
+ actual_type = type;
+ return value_zero (actual_type, not_lval);
+ }
+ else
+ {
+ /* In the case of a ref, ada_coerce_ref takes care
+ of determining the actual type. But the evaluation
+ should return a ref as it should be valid to ask
+ for its address; so rebuild a ref after coerce. */
+ arg1 = ada_coerce_ref (arg1);
+ return value_ref (arg1, TYPE_CODE_REF);
+ }
+ }
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (ada_tag_type (arg1), not_lval);
-
- return ada_value_tag (arg1);
-
- case OP_ATR_MIN:
- case OP_ATR_MAX:
- evaluate_subexp (nullptr, exp, pos, EVAL_SKIP);
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (value_type (arg1), not_lval);
+ /* Records and unions for which GNAT encodings have been
+ generated need to be statically fixed as well.
+ Otherwise, non-static fixing produces a type where
+ all dynamic properties are removed, which prevents "ptype"
+ from being able to completely describe the type.
+ For instance, a case statement in a variant record would be
+ replaced by the relevant components based on the actual
+ value of the discriminants. */
+ if ((type->code () == TYPE_CODE_STRUCT
+ && dynamic_template_type (type) != NULL)
+ || (type->code () == TYPE_CODE_UNION
+ && ada_find_parallel_type (type, "___XVU") != NULL))
+ return value_zero (to_static_fixed_type (type), not_lval);
+ }
+
+ value *arg1 = var_value_operation::evaluate (expect_type, exp, noside);
+ return ada_to_fixed_value (arg1);
+}
+
+bool
+ada_var_value_operation::resolve (struct expression *exp,
+ bool deprocedure_p,
+ bool parse_completion,
+ innermost_block_tracker *tracker,
+ struct type *context_type)
+{
+ symbol *sym = std::get<0> (m_storage).symbol;
+ if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
+ {
+ block_symbol resolved
+ = ada_resolve_variable (sym, std::get<0> (m_storage).block,
+ context_type, parse_completion,
+ deprocedure_p, tracker);
+ std::get<0> (m_storage) = resolved;
+ }
+
+ if (deprocedure_p
+ && (SYMBOL_TYPE (std::get<0> (m_storage).symbol)->code ()
+ == TYPE_CODE_FUNC))
+ return true;
+
+ return false;
+}
+
+value *
+ada_atr_val_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *arg = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
+ return ada_val_atr (noside, std::get<0> (m_storage), arg);
+}
+
+value *
+ada_unop_ind_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *arg1 = std::get<0> (m_storage)->evaluate (expect_type, exp, noside);
+
+ struct type *type = ada_check_typedef (value_type (arg1));
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ if (ada_is_array_descriptor_type (type))
+ /* GDB allows dereferencing GNAT array descriptors. */
+ {
+ struct type *arrType = ada_type_of_array (arg1, 0);
+
+ if (arrType == NULL)
+ error (_("Attempt to dereference null array pointer."));
+ return value_at_lazy (arrType, 0);
+ }
+ else if (type->code () == TYPE_CODE_PTR
+ || type->code () == TYPE_CODE_REF
+ /* In C you can dereference an array to get the 1st elt. */
+ || type->code () == TYPE_CODE_ARRAY)
+ {
+ /* As mentioned in the OP_VAR_VALUE case, tagged types can
+ only be determined by inspecting the object's tag.
+ This means that we need to evaluate completely the
+ expression in order to get its type. */
+
+ if ((type->code () == TYPE_CODE_REF
+ || type->code () == TYPE_CODE_PTR)
+ && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
+ {
+ arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
+ EVAL_NORMAL);
+ type = value_type (ada_value_ind (arg1));
+ }
+ else
+ {
+ type = to_static_fixed_type
+ (ada_aligned_type
+ (ada_check_typedef (TYPE_TARGET_TYPE (type))));
+ }
+ ada_ensure_varsize_limit (type);
+ return value_zero (type, lval_memory);
+ }
+ else if (type->code () == TYPE_CODE_INT)
+ {
+ /* 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_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
- {
- binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
- return value_binop (arg1, arg2,
- op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
- }
+ return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
+ (CORE_ADDR) value_as_address (arg1));
+ }
- case OP_ATR_MODULUS:
- {
- struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
+ struct type *target_type = (to_static_fixed_type
+ (ada_aligned_type
+ (ada_check_typedef (TYPE_TARGET_TYPE (type)))));
+ ada_ensure_varsize_limit (target_type);
- evaluate_subexp (nullptr, exp, pos, EVAL_SKIP);
- if (noside == EVAL_SKIP)
- goto nosideret;
+ if (ada_is_array_descriptor_type (type))
+ /* GDB allows dereferencing GNAT array descriptors. */
+ return ada_coerce_to_simple_array (arg1);
+ else
+ return ada_value_ind (arg1);
+}
- if (!ada_is_modular_type (type_arg))
- error (_("'modulus must be applied to modular type"));
+value *
+ada_structop_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
+ const char *str = std::get<1> (m_storage).c_str ();
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ struct type *type;
+ struct type *type1 = value_type (arg1);
- return value_from_longest (TYPE_TARGET_TYPE (type_arg),
- ada_modulus (type_arg));
- }
+ if (ada_is_tagged_type (type1, 1))
+ {
+ type = ada_lookup_struct_elt_type (type1, str, 1, 1);
+ /* If the field is not found, check if it exists in the
+ extension of this object's type. This means that we
+ need to evaluate completely the expression. */
- case OP_ATR_POS:
- evaluate_subexp (nullptr, exp, pos, EVAL_SKIP);
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- type = builtin_type (exp->gdbarch)->builtin_int;
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (type, not_lval);
+ if (type == NULL)
+ {
+ arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp,
+ EVAL_NORMAL);
+ arg1 = ada_value_struct_elt (arg1, str, 0);
+ arg1 = unwrap_value (arg1);
+ type = value_type (ada_to_fixed_value (arg1));
+ }
+ }
else
- return value_pos_atr (type, arg1);
+ type = ada_lookup_struct_elt_type (type1, str, 1, 0);
- case OP_ATR_SIZE:
- arg1 = evaluate_subexp (nullptr, 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_CODE_REF)
- type = TYPE_TARGET_TYPE (type);
+ return value_zero (ada_aligned_type (type), lval_memory);
+ }
+ else
+ {
+ arg1 = ada_value_struct_elt (arg1, str, 0);
+ arg1 = unwrap_value (arg1);
+ return ada_to_fixed_value (arg1);
+ }
+}
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
- else
- return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
- TARGET_CHAR_BIT * TYPE_LENGTH (type));
-
- case OP_ATR_VAL:
- evaluate_subexp (nullptr, exp, pos, EVAL_SKIP);
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- type = exp->elts[pc + 2].type;
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (type, not_lval);
- else
- return value_val_atr (type, arg1);
+value *
+ada_funcall_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ const std::vector<operation_up> &args_up = std::get<1> (m_storage);
+ int nargs = args_up.size ();
+ std::vector<value *> argvec (nargs);
+ operation_up &callee_op = std::get<0> (m_storage);
+
+ ada_var_value_operation *avv
+ = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
+ if (avv != nullptr
+ && SYMBOL_DOMAIN (avv->get_symbol ()) == UNDEF_DOMAIN)
+ error (_("Unexpected unresolved symbol, %s, during evaluation"),
+ avv->get_symbol ()->print_name ());
+
+ value *callee = callee_op->evaluate (nullptr, exp, noside);
+ for (int i = 0; i < args_up.size (); ++i)
+ argvec[i] = args_up[i]->evaluate (nullptr, exp, noside);
+
+ if (ada_is_constrained_packed_array_type
+ (desc_base_type (value_type (callee))))
+ callee = ada_coerce_to_simple_array (callee);
+ else if (value_type (callee)->code () == TYPE_CODE_ARRAY
+ && TYPE_FIELD_BITSIZE (value_type (callee), 0) != 0)
+ /* This is a packed array that has already been fixed, and
+ therefore already coerced to a simple array. Nothing further
+ to do. */
+ ;
+ else if (value_type (callee)->code () == TYPE_CODE_REF)
+ {
+ /* Make sure we dereference references so that all the code below
+ feels like it's really handling the referenced value. Wrapping
+ types (for alignment) may be there, so make sure we strip them as
+ well. */
+ callee = ada_to_fixed_value (coerce_ref (callee));
+ }
+ else if (value_type (callee)->code () == TYPE_CODE_ARRAY
+ && VALUE_LVAL (callee) == lval_memory)
+ callee = value_addr (callee);
+
+ struct type *type = ada_check_typedef (value_type (callee));
+
+ /* Ada allows us to implicitly dereference arrays when subscripting
+ them. So, if this is an array typedef (encoding use for array
+ access types encoded as fat pointers), strip it now. */
+ if (type->code () == TYPE_CODE_TYPEDEF)
+ type = ada_typedef_target_type (type);
- case BINOP_EXP:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (value_type (arg1), not_lval);
- else
+ if (type->code () == TYPE_CODE_PTR)
+ {
+ switch (ada_check_typedef (TYPE_TARGET_TYPE (type))->code ())
{
- /* 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 TYPE_CODE_FUNC:
+ type = ada_check_typedef (TYPE_TARGET_TYPE (type));
+ break;
+ case TYPE_CODE_ARRAY:
+ break;
+ case TYPE_CODE_STRUCT:
+ if (noside != EVAL_AVOID_SIDE_EFFECTS)
+ callee = ada_value_ind (callee);
+ type = ada_check_typedef (TYPE_TARGET_TYPE (type));
+ break;
+ default:
+ error (_("cannot subscript or call something of type `%s'"),
+ ada_type_name (value_type (callee)));
+ break;
}
+ }
- case UNOP_PLUS:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- else
- return arg1;
-
- case UNOP_ABS:
- arg1 = evaluate_subexp (nullptr, 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);
+ switch (type->code ())
+ {
+ case TYPE_CODE_FUNC:
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ if (TYPE_TARGET_TYPE (type) == NULL)
+ error_call_unknown_return_type (NULL);
+ return allocate_value (TYPE_TARGET_TYPE (type));
+ }
+ return call_function_by_hand (callee, NULL, argvec);
+ case TYPE_CODE_INTERNAL_FUNCTION:
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ /* We don't know anything about what the internal
+ function might return, but we have to return
+ something. */
+ return value_zero (builtin_type (exp->gdbarch)->builtin_int,
+ not_lval);
else
- return arg1;
+ return call_internal_function (exp->gdbarch, exp->language_defn,
+ callee, nargs,
+ argvec.data ());
- case UNOP_IND:
- preeval_pos = *pos;
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- type = ada_check_typedef (value_type (arg1));
+ case TYPE_CODE_STRUCT:
+ {
+ int arity;
+
+ arity = ada_array_arity (type);
+ type = ada_array_element_type (type, nargs);
+ if (type == NULL)
+ error (_("cannot subscript or call a record"));
+ if (arity != nargs)
+ error (_("wrong number of subscripts; expecting %d"), arity);
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (ada_aligned_type (type), lval_memory);
+ return
+ unwrap_value (ada_value_subscript
+ (callee, nargs, argvec.data ()));
+ }
+ case TYPE_CODE_ARRAY:
if (noside == EVAL_AVOID_SIDE_EFFECTS)
{
- if (ada_is_array_descriptor_type (type))
- /* GDB allows dereferencing GNAT array descriptors. */
- {
- struct type *arrType = ada_type_of_array (arg1, 0);
-
- if (arrType == NULL)
- error (_("Attempt to dereference null array pointer."));
- return value_at_lazy (arrType, 0);
- }
- else if (type->code () == TYPE_CODE_PTR
- || type->code () == TYPE_CODE_REF
- /* In C you can dereference an array to get the 1st elt. */
- || type->code () == TYPE_CODE_ARRAY)
- {
- /* As mentioned in the OP_VAR_VALUE case, tagged types can
- only be determined by inspecting the object's tag.
- This means that we need to evaluate completely the
- expression in order to get its type. */
-
- if ((type->code () == TYPE_CODE_REF
- || type->code () == TYPE_CODE_PTR)
- && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
- {
- arg1
- = evaluate_subexp (nullptr, exp, &preeval_pos, EVAL_NORMAL);
- type = value_type (ada_value_ind (arg1));
- }
- else
- {
- type = to_static_fixed_type
- (ada_aligned_type
- (ada_check_typedef (TYPE_TARGET_TYPE (type))));
- }
- ada_ensure_varsize_limit (type);
- return value_zero (type, lval_memory);
- }
- else if (type->code () == TYPE_CODE_INT)
- {
- /* 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);
- }
- }
+ type = ada_array_element_type (type, nargs);
+ if (type == NULL)
+ error (_("element type of array unknown"));
else
- error (_("Attempt to take contents of a non-pointer value."));
+ return value_zero (ada_aligned_type (type), lval_memory);
}
- arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
- type = ada_check_typedef (value_type (arg1));
-
- if (type->code () == 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. */
+ return
+ unwrap_value (ada_value_subscript
+ (ada_coerce_to_simple_array (callee),
+ nargs, argvec.data ()));
+ case TYPE_CODE_PTR: /* Pointer to array */
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
{
- if (expect_type != NULL)
- return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
- arg1));
+ type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
+ type = ada_array_element_type (type, nargs);
+ if (type == NULL)
+ error (_("element type of array unknown"));
else
- return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
- (CORE_ADDR) value_as_address (arg1));
+ return value_zero (ada_aligned_type (type), lval_memory);
}
+ return
+ unwrap_value (ada_value_ptr_subscript (callee, nargs,
+ argvec.data ()));
- if (ada_is_array_descriptor_type (type))
- /* GDB allows dereferencing GNAT array descriptors. */
- return ada_coerce_to_simple_array (arg1);
- else
- return ada_value_ind (arg1);
-
- case STRUCTOP_STRUCT:
- tem = longest_to_int (exp->elts[pc + 1].longconst);
- (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
- preeval_pos = *pos;
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- struct type *type1 = value_type (arg1);
+ default:
+ error (_("Attempt to index or call something other than an "
+ "array or function"));
+ }
+}
- if (ada_is_tagged_type (type1, 1))
- {
- type = ada_lookup_struct_elt_type (type1,
- &exp->elts[pc + 2].string,
- 1, 1);
+bool
+ada_funcall_operation::resolve (struct expression *exp,
+ bool deprocedure_p,
+ bool parse_completion,
+ innermost_block_tracker *tracker,
+ struct type *context_type)
+{
+ operation_up &callee_op = std::get<0> (m_storage);
- /* If the field is not found, check if it exists in the
- extension of this object's type. This means that we
- need to evaluate completely the expression. */
+ ada_var_value_operation *avv
+ = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
+ if (avv == nullptr)
+ return false;
- if (type == NULL)
- {
- arg1
- = evaluate_subexp (nullptr, exp, &preeval_pos, EVAL_NORMAL);
- arg1 = ada_value_struct_elt (arg1,
- &exp->elts[pc + 2].string,
- 0);
- arg1 = unwrap_value (arg1);
- type = value_type (ada_to_fixed_value (arg1));
- }
- }
- else
- type =
- ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
- 0);
+ symbol *sym = avv->get_symbol ();
+ if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN)
+ return false;
- return value_zero (ada_aligned_type (type), lval_memory);
- }
- else
- {
- arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
- arg1 = unwrap_value (arg1);
- return ada_to_fixed_value (arg1);
- }
+ const std::vector<operation_up> &args_up = std::get<1> (m_storage);
+ int nargs = args_up.size ();
+ std::vector<value *> argvec (nargs);
- case OP_TYPE:
- /* The value is not supposed to be used. This is here to make it
- easier to accommodate expressions that contain types. */
- (*pos) += 2;
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return allocate_value (exp->elts[pc + 1].type);
- else
- error (_("Attempt to use a type name as an expression"));
-
- case OP_AGGREGATE:
- case OP_CHOICES:
- case OP_OTHERS:
- case OP_DISCRETE_RANGE:
- case OP_POSITIONAL:
- case OP_NAME:
- if (noside == EVAL_NORMAL)
- switch (op)
- {
- case OP_NAME:
- error (_("Undefined name, ambiguous name, or renaming used in "
- "component association: %s."), &exp->elts[pc+2].string);
- case OP_AGGREGATE:
- error (_("Aggregates only allowed on the right of an assignment"));
- default:
- internal_error (__FILE__, __LINE__,
- _("aggregate apparently mangled"));
- }
+ for (int i = 0; i < args_up.size (); ++i)
+ argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
- ada_forward_operator_length (exp, pc, &oplen, &nargs);
- *pos += oplen - 1;
- for (tem = 0; tem < nargs; tem += 1)
- ada_evaluate_subexp (NULL, exp, pos, noside);
- goto nosideret;
- }
+ const block *block = avv->get_block ();
+ block_symbol resolved
+ = ada_resolve_funcall (sym, block,
+ context_type, parse_completion,
+ nargs, argvec.data (),
+ tracker);
+
+ std::get<0> (m_storage)
+ = make_operation<ada_var_value_operation> (resolved);
+ return false;
+}
+
+bool
+ada_ternop_slice_operation::resolve (struct expression *exp,
+ bool deprocedure_p,
+ bool parse_completion,
+ innermost_block_tracker *tracker,
+ struct type *context_type)
+{
+ /* Historically this check was done during resolution, so we
+ continue that here. */
+ value *v = std::get<0> (m_storage)->evaluate (context_type, exp,
+ EVAL_AVOID_SIDE_EFFECTS);
+ if (ada_is_any_packed_array_type (value_type (v)))
+ error (_("cannot slice a packed array"));
+ return false;
+}
-nosideret:
- return eval_skip_value (exp);
}
+
\f
/* Return non-zero iff TYPE represents a System.Address type. */
create_excep_cond_exprs (struct ada_catchpoint *c,
enum ada_exception_catchpoint_kind ex)
{
- struct bp_location *bl;
-
/* Nothing to do if there's no specific exception to catch. */
if (c->excep_string.empty ())
return;
/* Iterate over all the catchpoint's locations, and parse an
expression for each. */
- for (bl = c->loc; bl != NULL; bl = bl->next)
+ for (bp_location *bl : c->locations ())
{
struct ada_catchpoint_location *ada_loc
= (struct ada_catchpoint_location *) bl;
{
std::string info = string_printf (_("`%s' Ada exception"),
c->excep_string.c_str ());
- uiout->text (info.c_str ());
+ uiout->text (info);
}
else
uiout->text (_("all Ada exceptions"));
std::string info
= string_printf (_("`%s' Ada exception handlers"),
c->excep_string.c_str ());
- uiout->text (info.c_str ());
+ uiout->text (info);
}
else
uiout->text (_("all Ada exceptions handlers"));
return name_matches_regex (decoded.c_str (), preg);
},
NULL,
+ SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
VARIABLES_DOMAIN);
for (objfile *objfile : current_program_space->objfiles ())
printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
}
- /* Operators */
-/* Information about operators given special treatment in functions
- below. */
-/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
-
-#define ADA_OPERATORS \
- OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
- OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
- OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
- OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
- OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
- OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
- OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
- OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
- OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
- OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
- OP_DEFN (OP_ATR_POS, 1, 2, 0) \
- OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
- OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
- OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
- OP_DEFN (UNOP_QUAL, 3, 1, 0) \
- OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
- OP_DEFN (OP_OTHERS, 1, 1, 0) \
- OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
- OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
-
-static void
-ada_operator_length (const struct expression *exp, int pc, int *oplenp,
- int *argsp)
-{
- switch (exp->elts[pc - 1].opcode)
- {
- default:
- operator_length_standard (exp, pc, oplenp, argsp);
- break;
-
-#define OP_DEFN(op, len, args, binop) \
- case op: *oplenp = len; *argsp = args; break;
- ADA_OPERATORS;
-#undef OP_DEFN
-
- case OP_AGGREGATE:
- *oplenp = 3;
- *argsp = longest_to_int (exp->elts[pc - 2].longconst);
- break;
-
- case OP_CHOICES:
- *oplenp = 3;
- *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
- break;
- }
-}
-
-/* Implementation of the exp_descriptor method operator_check. */
-
-static int
-ada_operator_check (struct expression *exp, int pos,
- int (*objfile_func) (struct objfile *objfile, void *data),
- void *data)
-{
- const union exp_element *const elts = exp->elts;
- struct type *type = NULL;
-
- switch (elts[pos].opcode)
- {
- case UNOP_IN_RANGE:
- case UNOP_QUAL:
- type = elts[pos + 1].type;
- break;
-
- default:
- return operator_check_standard (exp, pos, objfile_func, data);
- }
-
- /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
-
- if (type != nullptr && type->objfile_owner () != nullptr
- && objfile_func (type->objfile_owner (), data))
- return 1;
-
- return 0;
-}
-
-/* As for operator_length, but assumes PC is pointing at the first
- element of the operator, and gives meaningful results only for the
- Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
-
-static void
-ada_forward_operator_length (struct expression *exp, int pc,
- int *oplenp, int *argsp)
-{
- switch (exp->elts[pc].opcode)
- {
- default:
- *oplenp = *argsp = 0;
- break;
-
-#define OP_DEFN(op, len, args, binop) \
- case op: *oplenp = len; *argsp = args; break;
- ADA_OPERATORS;
-#undef OP_DEFN
-
- case OP_AGGREGATE:
- *oplenp = 3;
- *argsp = longest_to_int (exp->elts[pc + 1].longconst);
- break;
-
- case OP_CHOICES:
- *oplenp = 3;
- *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
- break;
-
- case OP_STRING:
- case OP_NAME:
- {
- int len = longest_to_int (exp->elts[pc + 1].longconst);
-
- *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
- *argsp = 0;
- break;
- }
- }
-}
-
-static int
-ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
-{
- enum exp_opcode op = exp->elts[elt].opcode;
- int oplen, nargs;
- int pc = elt;
- int i;
-
- ada_forward_operator_length (exp, elt, &oplen, &nargs);
-
- switch (op)
- {
- /* Ada attributes ('Foo). */
- case OP_ATR_FIRST:
- case OP_ATR_LAST:
- case OP_ATR_LENGTH:
- case OP_ATR_IMAGE:
- case OP_ATR_MAX:
- case OP_ATR_MIN:
- case OP_ATR_MODULUS:
- case OP_ATR_POS:
- case OP_ATR_SIZE:
- case OP_ATR_TAG:
- case OP_ATR_VAL:
- break;
-
- case UNOP_IN_RANGE:
- case UNOP_QUAL:
- /* XXX: gdb_sprint_host_address, type_sprint */
- fprintf_filtered (stream, _("Type @"));
- gdb_print_host_address (exp->elts[pc + 1].type, stream);
- fprintf_filtered (stream, " (");
- type_print (exp->elts[pc + 1].type, NULL, stream, 0);
- fprintf_filtered (stream, ")");
- break;
- case BINOP_IN_BOUNDS:
- fprintf_filtered (stream, " (%d)",
- longest_to_int (exp->elts[pc + 2].longconst));
- break;
- case TERNOP_IN_RANGE:
- break;
-
- case OP_AGGREGATE:
- case OP_OTHERS:
- case OP_DISCRETE_RANGE:
- case OP_POSITIONAL:
- case OP_CHOICES:
- break;
-
- case OP_NAME:
- case OP_STRING:
- {
- char *name = &exp->elts[elt + 2].string;
- int len = longest_to_int (exp->elts[elt + 1].longconst);
-
- fprintf_filtered (stream, "Text: `%.*s'", len, name);
- break;
- }
-
- default:
- return dump_subexp_body_standard (exp, stream, elt);
- }
-
- elt += oplen;
- for (i = 0; i < nargs; i += 1)
- elt = dump_subexp (exp, stream, elt);
-
- return elt;
-}
-
-/* The Ada extension of print_subexp (q.v.). */
-
-static void
-ada_print_subexp (struct expression *exp, int *pos,
- struct ui_file *stream, enum precedence prec)
-{
- int oplen, nargs, i;
- int pc = *pos;
- enum exp_opcode op = exp->elts[pc].opcode;
-
- ada_forward_operator_length (exp, pc, &oplen, &nargs);
-
- *pos += oplen;
- switch (op)
- {
- default:
- *pos -= oplen;
- print_subexp_standard (exp, pos, stream, prec);
- return;
-
- case OP_VAR_VALUE:
- fputs_filtered (exp->elts[pc + 2].symbol->natural_name (), stream);
- return;
-
- case BINOP_IN_BOUNDS:
- /* XXX: sprint_subexp */
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fputs_filtered (" in ", stream);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fputs_filtered ("'range", stream);
- if (exp->elts[pc + 1].longconst > 1)
- fprintf_filtered (stream, "(%ld)",
- (long) exp->elts[pc + 1].longconst);
- return;
-
- case TERNOP_IN_RANGE:
- if (prec >= PREC_EQUAL)
- fputs_filtered ("(", stream);
- /* XXX: sprint_subexp */
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fputs_filtered (" in ", stream);
- print_subexp (exp, pos, stream, PREC_EQUAL);
- fputs_filtered (" .. ", stream);
- print_subexp (exp, pos, stream, PREC_EQUAL);
- if (prec >= PREC_EQUAL)
- fputs_filtered (")", stream);
- return;
-
- case OP_ATR_FIRST:
- case OP_ATR_LAST:
- case OP_ATR_LENGTH:
- case OP_ATR_IMAGE:
- case OP_ATR_MAX:
- case OP_ATR_MIN:
- case OP_ATR_MODULUS:
- case OP_ATR_POS:
- case OP_ATR_SIZE:
- case OP_ATR_TAG:
- case OP_ATR_VAL:
- if (exp->elts[*pos].opcode == OP_TYPE)
- {
- if (exp->elts[*pos + 1].type->code () != TYPE_CODE_VOID)
- LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
- &type_print_raw_options);
- *pos += 3;
- }
- else
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fprintf_filtered (stream, "'%s", ada_attribute_name (op));
- if (nargs > 1)
- {
- int tem;
-
- for (tem = 1; tem < nargs; tem += 1)
- {
- fputs_filtered ((tem == 1) ? " (" : ", ", stream);
- print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
- }
- fputs_filtered (")", stream);
- }
- return;
-
- case UNOP_QUAL:
- type_print (exp->elts[pc + 1].type, "", stream, 0);
- fputs_filtered ("'(", stream);
- print_subexp (exp, pos, stream, PREC_PREFIX);
- fputs_filtered (")", stream);
- return;
-
- case UNOP_IN_RANGE:
- /* XXX: sprint_subexp */
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fputs_filtered (" in ", stream);
- LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
- &type_print_raw_options);
- return;
-
- case OP_DISCRETE_RANGE:
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fputs_filtered ("..", stream);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- return;
-
- case OP_OTHERS:
- fputs_filtered ("others => ", stream);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- return;
-
- case OP_CHOICES:
- for (i = 0; i < nargs-1; i += 1)
- {
- if (i > 0)
- fputs_filtered ("|", stream);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- }
- fputs_filtered (" => ", stream);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- return;
-
- case OP_POSITIONAL:
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- return;
-
- case OP_AGGREGATE:
- fputs_filtered ("(", stream);
- for (i = 0; i < nargs; i += 1)
- {
- if (i > 0)
- fputs_filtered (", ", stream);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- }
- fputs_filtered (")", stream);
- return;
- }
-}
-
-/* Table mapping opcodes into strings for printing operators
- and precedences of the operators. */
-
-static const struct op_print ada_op_print_tab[] = {
- {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
- {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
- {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
- {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
- {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
- {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
- {"=", BINOP_EQUAL, PREC_EQUAL, 0},
- {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
- {"<=", BINOP_LEQ, PREC_ORDER, 0},
- {">=", BINOP_GEQ, PREC_ORDER, 0},
- {">", BINOP_GTR, PREC_ORDER, 0},
- {"<", BINOP_LESS, PREC_ORDER, 0},
- {">>", BINOP_RSH, PREC_SHIFT, 0},
- {"<<", BINOP_LSH, PREC_SHIFT, 0},
- {"+", BINOP_ADD, PREC_ADD, 0},
- {"-", BINOP_SUB, PREC_ADD, 0},
- {"&", BINOP_CONCAT, PREC_ADD, 0},
- {"*", BINOP_MUL, PREC_MUL, 0},
- {"/", BINOP_DIV, PREC_MUL, 0},
- {"rem", BINOP_REM, PREC_MUL, 0},
- {"mod", BINOP_MOD, PREC_MUL, 0},
- {"**", BINOP_EXP, PREC_REPEAT, 0},
- {"@", BINOP_REPEAT, PREC_REPEAT, 0},
- {"-", UNOP_NEG, PREC_PREFIX, 0},
- {"+", UNOP_PLUS, PREC_PREFIX, 0},
- {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
- {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
- {"abs ", UNOP_ABS, PREC_PREFIX, 0},
- {".all", UNOP_IND, PREC_SUFFIX, 1},
- {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
- {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
- {NULL, OP_NULL, PREC_SUFFIX, 0}
-};
\f
/* Language vector */
-static const struct exp_descriptor ada_exp_descriptor = {
- ada_print_subexp,
- ada_operator_length,
- ada_operator_check,
- ada_dump_subexp_body,
- ada_evaluate_subexp
-};
-
/* symbol_name_matcher_ftype adapter for wild_match. */
static bool
lookup_name,
NULL,
NULL,
+ SEARCH_GLOBAL_BLOCK | SEARCH_STATIC_BLOCK,
ALL_DOMAIN);
/* At this point scan through the misc symbol vectors and add each
return ada_parse (ps);
}
- /* See language.h.
-
- Same as evaluate_type (*EXP), but resolves ambiguous symbol references
- (marked by OP_VAR_VALUE nodes in which the symbol has an undefined
- namespace) and converts operators that are user-defined into
- appropriate function calls. If CONTEXT_TYPE is non-null, it provides
- a preferred result type [at the moment, only type void has any
- effect---causing procedures to be preferred over functions in calls].
- A null CONTEXT_TYPE indicates that a non-void return type is
- preferred. May change (expand) *EXP. */
-
- void post_parser (expression_up *expp, struct parser_state *ps)
- const override
- {
- struct type *context_type = NULL;
- int pc = 0;
-
- if (ps->void_context_p)
- context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
-
- resolve_subexp (expp, &pc, 1, context_type, ps->parse_completion,
- ps->block_tracker);
- }
-
/* See language.h. */
void emitchar (int ch, struct type *chtype,
const struct lang_varobj_ops *varobj_ops () const override
{ return &ada_varobj_ops; }
- /* See language.h. */
-
- const struct exp_descriptor *expression_ops () const override
- { return &ada_exp_descriptor; }
-
- /* See language.h. */
-
- const struct op_print *opcode_print_table () const override
- { return ada_op_print_tab; }
-
protected:
/* See language.h. */
add_basic_prefix_cmd ("ada", no_class,
_("Prefix command for changing Ada-specific settings."),
- &set_ada_list, "set ada ", 0, &setlist);
+ &set_ada_list, 0, &setlist);
add_show_prefix_cmd ("ada", no_class,
_("Generic command for showing Ada-specific settings."),
- &show_ada_list, "show ada ", 0, &showlist);
+ &show_ada_list, 0, &showlist);
add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
&trust_pad_over_xvs, _("\
add_basic_prefix_cmd ("ada", class_maintenance,
_("Set Ada maintenance-related variables."),
- &maint_set_ada_cmdlist, "maintenance set ada ",
+ &maint_set_ada_cmdlist,
0/*allow-unknown*/, &maintenance_set_cmdlist);
add_show_prefix_cmd ("ada", class_maintenance,
_("Show Ada maintenance-related variables."),
- &maint_show_ada_cmdlist, "maintenance show ada ",
+ &maint_show_ada_cmdlist,
0/*allow-unknown*/, &maintenance_show_cmdlist);
add_setshow_boolean_cmd
DWARF attribute."),
NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
- decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
+ decoded_names_store = htab_create_alloc (256, htab_hash_string,
+ htab_eq_string,
NULL, xcalloc, xfree);
/* The ada-lang observers. */
- gdb::observers::new_objfile.attach (ada_new_objfile_observer);
- gdb::observers::free_objfile.attach (ada_free_objfile_observer);
- gdb::observers::inferior_exit.attach (ada_inferior_exit);
+ gdb::observers::new_objfile.attach (ada_new_objfile_observer, "ada-lang");
+ gdb::observers::free_objfile.attach (ada_free_objfile_observer, "ada-lang");
+ gdb::observers::inferior_exit.attach (ada_inferior_exit, "ada-lang");
}