From d3c54a1ce8b250acf83dda2653393f29b70d3390 Mon Sep 17 00:00:00 2001 From: Tom Tromey Date: Mon, 8 Mar 2021 07:27:57 -0700 Subject: [PATCH] Remove now-unused Ada evaluator code Now that the Ada parser has switched to the new style, there is no need for the old Ada evaluation code. gdb/ChangeLog 2021-03-08 Tom Tromey * ada-lang.c (resolve_subexp, replace_operator_with_call) (evaluate_subexp_type, assign_aggregate) (aggregate_assign_positional, aggregate_assign_from_choices) (aggregate_assign_others, ada_evaluate_subexp_for_cast) (ada_evaluate_subexp, ADA_OPERATORS, ada_operator_length) (ada_operator_check, ada_forward_operator_length) (ada_dump_subexp_body, ada_print_subexp, ada_exp_descriptor): Remove. (post_parser): Update. (class ada_language) : Remove. --- gdb/ChangeLog | 13 + gdb/ada-lang.c | 2104 ++++-------------------------------------------- 2 files changed, 188 insertions(+), 1929 deletions(-) diff --git a/gdb/ChangeLog b/gdb/ChangeLog index a0dde3f4bb4..0853471221e 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,16 @@ +2021-03-08 Tom Tromey + + * ada-lang.c (resolve_subexp, replace_operator_with_call) + (evaluate_subexp_type, assign_aggregate) + (aggregate_assign_positional, aggregate_assign_from_choices) + (aggregate_assign_others, ada_evaluate_subexp_for_cast) + (ada_evaluate_subexp, ADA_OPERATORS, ada_operator_length) + (ada_operator_check, ada_forward_operator_length) + (ada_dump_subexp_body, ada_print_subexp, ada_exp_descriptor): + Remove. + (post_parser): Update. + (class ada_language) : Remove. + 2021-03-08 Tom Tromey * m2-lang.h (class m2_language) &, 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); @@ -139,8 +132,6 @@ static int discrete_type_p (struct type *); 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 *); @@ -209,36 +200,9 @@ 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); - -static void aggregate_assign_positional (struct value *, struct value *, - struct expression *, - int *, std::vector &, - LONGEST, LONGEST); - - -static void aggregate_assign_others (struct value *, struct value *, - struct expression *, - int *, std::vector &, - LONGEST, LONGEST); - - static void add_component_interval (LONGEST, LONGEST, std::vector &); -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 @@ -3528,293 +3492,6 @@ ada_resolve_variable (struct symbol *sym, const struct block *block, 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. */ @@ -3997,38 +3674,6 @@ ada_resolve_function (std::vector &syms, 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), @@ -9131,16 +8776,6 @@ ada_enum_name (const char *name) } } -/* 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. */ @@ -9392,17 +9027,27 @@ ada_value_equal (struct value *arg1, struct value *arg2) 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 &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)); @@ -9419,41 +9064,56 @@ assign_component (struct value *container, struct value *lhs, LONGEST index, 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 (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; +} + +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 &indices, + LONGEST low, LONGEST high) +{ + for (auto &item : m_components) + item->assign (container, lhs, exp, indices, low, high); } /* 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. */ + type, evaluate an assignment of this aggregate's value to LHS. + 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). */ -static struct value * -assign_aggregate (struct value *container, - struct value *lhs, struct expression *exp, - int *pos, enum noside noside) +void +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))) @@ -9482,317 +9142,47 @@ assign_aggregate (struct value *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); +} + +bool +ada_positional_component::uses_objfile (struct objfile *objfile) +{ + return m_op->uses_objfile (objfile); +} - return container; +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 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 &indices, - LONGEST low, LONGEST high) + 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 &indices, + LONGEST low, LONGEST high) { - LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low; - + 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 &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 &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 &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 (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 &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 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) -{ - 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 &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); - assign_component (container, lhs, ind, exp, m_op); - } -} - -bool -ada_discrete_range_association::uses_objfile (struct objfile *objfile) +bool +ada_discrete_range_association::uses_objfile (struct objfile *objfile) { return m_low->uses_objfile (objfile) || m_high->uses_objfile (objfile); } @@ -10287,58 +9677,6 @@ ada_value_cast (struct type *type, struct value *arg2) 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 * @@ -11297,852 +10635,111 @@ ada_funcall_operation::evaluate (struct type *expect_type, callee, nargs, argvec.data ()); - 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) - { - 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 (callee_op.get ()); - if (avv == nullptr) - return false; - - symbol *sym = avv->get_symbol (); - if (SYMBOL_DOMAIN (sym) != UNDEF_DOMAIN) - return false; - - const std::vector &args_up = std::get<1> (m_storage); - int nargs = args_up.size (); - std::vector 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 (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 TYPE_CODE_STRUCT: + { + int arity; - 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)); + 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 (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 &args_up = std::get<1> (m_storage); + int nargs = args_up.size (); + std::vector 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 (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; +} -nosideret: - return eval_skip_value (exp); } + /* Return non-zero iff TYPE represents a System.Address type. */ @@ -14055,336 +12652,6 @@ info_exceptions_command (const char *regexp, int from_tty) printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr)); } - /* Operators */ -/* Information about operators given special treatment in functions - below. */ -/* Format: OP_DEFN (, , <# args>, ). */ - -#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. */ @@ -14425,14 +12692,6 @@ static const struct op_print ada_op_print_tab[] = { /* 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 @@ -15030,14 +13289,6 @@ public: 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. */ @@ -15104,11 +13355,6 @@ public: /* 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; } -- 2.30.2