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 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;
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. */
/* See ada-lang.h. */
block_symbol
-ada_find_operator_symbol (enum exp_opcode op, int parse_completion,
+ada_find_operator_symbol (enum exp_opcode op, bool parse_completion,
int nargs, value *argvec[])
{
if (possible_user_operator_p (op, argvec))
block_symbol
ada_resolve_funcall (struct symbol *sym, const struct block *block,
struct type *context_type,
- int parse_completion,
+ bool parse_completion,
int nargs, value *argvec[],
innermost_block_tracker *tracker)
{
block_symbol
ada_resolve_variable (struct symbol *sym, const struct block *block,
struct type *context_type,
- int parse_completion,
+ bool parse_completion,
int deprocedure_p,
innermost_block_tracker *tracker)
{
return candidates[i];
}
-/* 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. */
-
-static struct value *
-resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
- struct type *context_type, int parse_completion,
- innermost_block_tracker *tracker)
-{
- 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)
- {
- 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;
-
- 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;
-
- case OP_STRING:
- break;
-
- default:
- error (_("Unexpected operator during name resolution"));
- }
-
- argvec = XALLOCAVEC (struct value *, nargs + 1);
- for (i = 0; i < nargs; i += 1)
- {
- 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);
- }
- 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)
- {
- block_symbol resolved
- = ada_resolve_variable (exp->elts[pc + 2].symbol,
- exp->elts[pc + 1].block,
- context_type, parse_completion,
- deprocedure_p, tracker);
- exp->elts[pc + 1].block = resolved.block;
- exp->elts[pc + 2].symbol = resolved.symbol;
- }
-
- 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;
-
- case OP_FUNCALL:
- {
- if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
- && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
- {
- block_symbol resolved
- = ada_resolve_funcall (exp->elts[pc + 5].symbol,
- exp->elts[pc + 4].block,
- context_type, parse_completion,
- nargs, argvec,
- tracker);
- exp->elts[pc + 4].block = resolved.block;
- exp->elts[pc + 5].symbol = resolved.symbol;
- }
- }
- 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:
- {
- block_symbol found = ada_find_operator_symbol (op, parse_completion,
- nargs, argvec);
- if (found.symbol == nullptr)
- break;
-
- replace_operator_with_call (expp, pc, nargs, 1,
- found.symbol, found.block);
- exp = expp->get ();
- }
- break;
-
- case OP_TYPE:
- case OP_REGISTER:
- return NULL;
- }
-
- *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);
- else
- return evaluate_subexp_type (exp, pos);
-}
-
-/* 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
}
}
-/* 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. */
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)
-{
- LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + 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);
- }
- 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)
-{
- 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));
-
- choice_pos = *pos += 3;
-
- 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)
- {
- LONGEST lower, upper;
- enum exp_opcode op = exp->elts[choice_pos].opcode;
-
- 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;
-
- 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;
- }
-
- if (lower <= upper && (lower < low || upper > high))
- error (_("Index in component association out of bounds."));
-
- add_component_interval (lower, upper, indices);
- while (lower <= upper)
- {
- int pos1;
-
- pos1 = expr_pc;
- assign_component (container, lhs, lower, exp, &pos1);
- lower += 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)
-{
- int i;
- int expr_pc = *pos + 1;
-
- int num_indices = indices.size ();
- for (i = 0; i < num_indices - 2; i += 2)
- {
- LONGEST ind;
-
- for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
- {
- int localpos;
-
- localpos = expr_pc;
- assign_component (container, lhs, ind, exp, &localpos);
- }
- }
- ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
-}
-
-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, operation_up &arg)
-{
- scoped_value_mark mark;
-
- struct value *elt;
- struct type *lhs_type = check_typedef (value_type (lhs));
-
- if (lhs_type->code () == TYPE_CODE_ARRAY)
- {
- struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
- struct value *index_val = value_from_longest (index_type, index);
-
- elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
- }
- else
- {
- elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
- elt = ada_to_fixed_value (elt);
- }
-
- 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,
- arg->evaluate (nullptr, exp,
- EVAL_NORMAL));
-}
-
-bool
-ada_aggregate_component::uses_objfile (struct objfile *objfile)
-{
- for (const auto &item : m_components)
- if (item->uses_objfile (objfile))
- return true;
- return false;
-}
-
-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);
-}
-
-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);
-}
-
-void
-ada_aggregate_operation::assign_aggregate (struct value *container,
- struct value *lhs,
- struct expression *exp)
-{
- struct type *lhs_type;
- LONGEST low_index, high_index;
-
- container = ada_coerce_ref (container);
- if (ada_is_direct_array_type (value_type (container)))
- container = ada_coerce_to_simple_array (container);
- lhs = ada_coerce_ref (lhs);
- if (!deprecated_value_modifiable (lhs))
- error (_("Left operand of assignment is not a modifiable lvalue."));
-
- lhs_type = check_typedef (value_type (lhs));
- if (ada_is_direct_array_type (lhs_type))
- {
- lhs = ada_coerce_to_simple_array (lhs);
- lhs_type = check_typedef (value_type (lhs));
- low_index = lhs_type->bounds ()->low.const_val ();
- high_index = lhs_type->bounds ()->high.const_val ();
- }
- else if (lhs_type->code () == TYPE_CODE_STRUCT)
- {
- low_index = 0;
- high_index = num_visible_fields (lhs_type) - 1;
- }
- else
- error (_("Left-hand side must be array or record."));
-
- std::vector<LONGEST> indices (4);
- indices[0] = indices[1] = low_index - 1;
- indices[2] = indices[3] = high_index + 1;
-
- std::get<0> (m_storage)->assign (container, lhs, exp, indices,
- low_index, high_index);
-}
-
-bool
-ada_positional_component::uses_objfile (struct objfile *objfile)
+
+bool
+ada_positional_component::uses_objfile (struct objfile *objfile)
{
return m_op->uses_objfile (objfile);
}
if (noside != EVAL_NORMAL)
return arg1;
- ag_op->assign_aggregate (arg1, arg1, exp);
+ arg1 = ag_op->assign_aggregate (arg1, arg1, exp);
return ada_value_assign (arg1, arg1);
}
/* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
if (VALUE_LVAL (arg1) == lval_internalvar)
type = NULL;
value *arg2 = std::get<1> (m_storage)->evaluate (type, exp, noside);
- if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
return arg1;
if (VALUE_LVAL (arg1) == lval_internalvar)
{
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);
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);
}
enum noside noside, enum exp_opcode op,
struct value *arg1, struct type *type)
{
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
-
struct value *arg2, *arg3;
switch (type->code ())
{
if (type->code () == TYPE_CODE_REF)
type = TYPE_TARGET_TYPE (type);
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ 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,
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_binop (arg1, arg2, op);
}
}
if (noside == EVAL_AVOID_SIDE_EFFECTS)
return value_zero (expect_type, not_lval);
- value *val = evaluate_var_msym_value (noside,
- std::get<1> (m_storage),
- std::get<0> (m_storage));
+ const bound_minimal_symbol &b = std::get<0> (m_storage);
+ value *val = evaluate_var_msym_value (noside, b.objfile, b.minsym);
val = ada_value_cast (expect_type, val);
enum noside noside)
{
value *val = evaluate_var_value (noside,
- std::get<1> (m_storage),
- std::get<0> (m_storage));
+ std::get<0> (m_storage).block,
+ std::get<0> (m_storage).symbol);
val = ada_value_cast (expect_type, val);
struct expression *exp,
enum noside noside)
{
- symbol *sym = std::get<0> (m_storage);
+ symbol *sym = std::get<0> (m_storage).symbol;
if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
/* Only encountered when an unresolved symbol occurs in a
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 = var_value_operation::evaluate (nullptr, exp,
- EVAL_NORMAL);
+ value *arg1 = evaluate (nullptr, exp, EVAL_NORMAL);
if (type->code () != TYPE_CODE_REF)
{
innermost_block_tracker *tracker,
struct type *context_type)
{
- symbol *sym = std::get<0> (m_storage);
+ symbol *sym = std::get<0> (m_storage).symbol;
if (SYMBOL_DOMAIN (sym) == UNDEF_DOMAIN)
{
block_symbol resolved
- = ada_resolve_variable (sym, std::get<1> (m_storage),
+ = ada_resolve_variable (sym, std::get<0> (m_storage).block,
context_type, parse_completion,
deprocedure_p, tracker);
- std::get<0> (m_storage) = resolved.symbol;
- std::get<1> (m_storage) = resolved.block;
+ std::get<0> (m_storage) = resolved;
}
if (deprocedure_p
- && SYMBOL_TYPE (std::get<0> (m_storage))->code () == TYPE_CODE_FUNC)
+ && (SYMBOL_TYPE (std::get<0> (m_storage).symbol)->code ()
+ == TYPE_CODE_FUNC))
return true;
return false;
(CORE_ADDR) value_as_address (arg1));
}
+ struct type *target_type = (to_static_fixed_type
+ (ada_aligned_type
+ (ada_check_typedef (TYPE_TARGET_TYPE (type)))));
+ ada_ensure_varsize_limit (target_type);
+
if (ada_is_array_descriptor_type (type))
/* GDB allows dereferencing GNAT array descriptors. */
return ada_coerce_to_simple_array (arg1);
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)
- {
- 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 (callee),
- nargs, argvec.data ()));
- 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 (callee, nargs,
- argvec.data ()));
-
- default:
- error (_("Attempt to index or call something other than an "
- "array or function"));
- }
-}
-
-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);
-
- ada_var_value_operation *avv
- = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
- if (avv == nullptr)
- return false;
-
- symbol *sym = avv->get_symbol ();
- if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN)
- return false;
-
- const std::vector<operation_up> &args_up = std::get<1> (m_storage);
- int nargs = args_up.size ();
- std::vector<value *> argvec (nargs);
-
- for (int i = 0; i < args_up.size (); ++i)
- argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
-
- 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.symbol,
- resolved.block);
- 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;
-}
-
-}
-
-/* Implement the evaluate_exp routine in the exp_descriptor structure
- for the Ada language. */
-
-static struct value *
-ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
- int *pos, enum noside noside)
-{
- 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)
- {
- default:
- *pos -= 1;
- arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
-
- if (noside == EVAL_NORMAL)
- arg1 = unwrap_value (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.
-
- 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);
-
- return 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;
- }
-
- 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);
-
- 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;
-
- 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);
- 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;
-
- 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;
- return ada_mult_binop (expect_type, exp, noside, op,
- arg1, arg2);
-
- 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;
- return ada_equal_binop (expect_type, exp, noside, op, arg1, arg2);
-
- case UNOP_NEG:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- return ada_unop_neg (expect_type, exp, noside, op, arg1);
-
- case BINOP_LOGICAL_AND:
- case BINOP_LOGICAL_OR:
- case UNOP_LOGICAL_NOT:
- {
- struct value *val;
-
- *pos -= 1;
- val = evaluate_subexp_standard (expect_type, exp, pos, noside);
- type = language_bool_type (exp->language_defn, exp->gdbarch);
- return value_cast (type, val);
- }
-
- case BINOP_BITWISE_AND:
- case BINOP_BITWISE_IOR:
- case BINOP_BITWISE_XOR:
- {
- struct value *val;
-
- arg1 = evaluate_subexp (nullptr, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
- *pos = pc;
- val = evaluate_subexp_standard (expect_type, exp, pos, noside);
-
- return value_cast (value_type (arg1), val);
- }
-
- case OP_VAR_VALUE:
- *pos -= 1;
-
- if (noside == EVAL_SKIP)
- {
- *pos += 4;
- goto nosideret;
- }
-
- 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 (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- 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))
- {
- *pos += 4;
- return value_zero (to_static_fixed_type (type), not_lval);
- }
- }
-
- arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
- return ada_to_fixed_value (arg1);
-
- case OP_FUNCALL:
- (*pos) += 2;
-
- /* 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 (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 ());
- 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;
- }
-
- 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)
- {
- /* 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]));
- }
- else if (value_type (argvec[0])->code () == TYPE_CODE_ARRAY
- && VALUE_LVAL (argvec[0]) == lval_memory)
- argvec[0] = value_addr (argvec[0]);
-
- type = ada_check_typedef (value_type (argvec[0]));
-
- /* 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 (type->code () == TYPE_CODE_PTR)
- {
- 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;
- }
- }
-
- 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 (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"));
- }
-
- 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);
-
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- return ada_ternop_slice (exp, noside, array, low_bound_val,
- high_bound_val);
- }
-
- case UNOP_IN_RANGE:
- (*pos) += 2;
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- type = check_typedef (exp->elts[pc + 1].type);
- return ada_unop_in_range (expect_type, exp, noside, op, arg1, type);
-
- 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;
-
- tem = longest_to_int (exp->elts[pc + 1].longconst);
-
- return ada_binop_in_bounds (exp, noside, arg1, arg2, tem);
-
- 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);
-
- return eval_ternop_in_range (expect_type, exp, noside, arg1, arg2, arg3);
-
- case OP_ATR_FIRST:
- case OP_ATR_LAST:
- case OP_ATR_LENGTH:
- {
- struct type *type_arg;
-
- 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;
- }
-
- 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 (noside == EVAL_SKIP)
- goto nosideret;
-
- return ada_unop_atr (exp, noside, op, arg1, type_arg, tem);
- }
-
- case OP_ATR_TAG:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- return ada_atr_tag (expect_type, exp, noside, op, 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;
- return ada_binop_minmax (expect_type, exp, noside, op, arg1, arg2);
-
- case OP_ATR_MODULUS:
- {
- struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
-
- evaluate_subexp (nullptr, exp, pos, EVAL_SKIP);
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- if (!ada_is_modular_type (type_arg))
- error (_("'modulus must be applied to modular type"));
-
- return value_from_longest (TYPE_TARGET_TYPE (type_arg),
- ada_modulus (type_arg));
- }
-
-
- case OP_ATR_POS:
- evaluate_subexp (nullptr, exp, pos, EVAL_SKIP);
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- return ada_pos_atr (expect_type, exp, noside, op, arg1);
-
- case OP_ATR_SIZE:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- return ada_atr_size (expect_type, exp, noside, op, arg1);
-
- 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;
- return ada_val_atr (noside, type, arg1);
-
- case BINOP_EXP:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- return ada_binop_exp (expect_type, exp, noside, op, arg1, arg2);
-
- 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;
- return ada_abs (expect_type, exp, noside, op, arg1);
-
- 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));
+ 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);
+
+ ada_var_value_operation *avv
+ = dynamic_cast<ada_var_value_operation *> (callee_op.get ());
+ if (avv == nullptr)
+ return false;
- /* 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. */
+ symbol *sym = avv->get_symbol ();
+ if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN)
+ 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);
+ const std::vector<operation_up> &args_up = std::get<1> (m_storage);
+ int nargs = args_up.size ();
+ std::vector<value *> argvec (nargs);
- 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);
- }
+ for (int i = 0; i < args_up.size (); ++i)
+ argvec[i] = args_up[i]->evaluate (nullptr, exp, EVAL_AVOID_SIDE_EFFECTS);
- 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"));
- }
+ const block *block = avv->get_block ();
+ block_symbol resolved
+ = ada_resolve_funcall (sym, block,
+ context_type, parse_completion,
+ nargs, argvec.data (),
+ tracker);
- 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;
- }
+ 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");
}
projects / deliverable / binutils-gdb.git / blobdiff