#include "gdbarch.h"
#include "gdbcmd.h"
#include "f-array-walker.h"
+#include "f-exp.h"
#include <math.h>
int arg_num, bool is_internal_call_p,
struct type *func_type,
enum noside noside);
+static value *fortran_prepare_argument (struct expression *exp,
+ expr::operation *subexp,
+ int arg_num, bool is_internal_call_p,
+ struct type *func_type, enum noside noside);
/* Return the encoding that should be used for the character type
TYPE. */
};
\f
+/* A helper function for the "bound" intrinsics that checks that TYPE
+ is an array. LBOUND_P is true for lower bound; this is used for
+ the error message, if any. */
+
+static void
+fortran_require_array (struct type *type, bool lbound_p)
+{
+ type = check_typedef (type);
+ if (type->code () != TYPE_CODE_ARRAY)
+ {
+ if (lbound_p)
+ error (_("LBOUND can only be applied to arrays"));
+ else
+ error (_("UBOUND can only be applied to arrays"));
+ }
+}
+
/* Create an array containing the lower bounds (when LBOUND_P is true) or
the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
array type). GDBARCH is the current architecture. */
return value_from_longest (result_type, is_associated ? 1 : 0);
}
+struct value *
+eval_op_f_associated (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1)
+{
+ return fortran_associated (exp->gdbarch, exp->language_defn, arg1);
+}
+
+struct value *
+eval_op_f_associated (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1,
+ struct value *arg2)
+{
+ return fortran_associated (exp->gdbarch, exp->language_defn, arg1, arg2);
+}
/* A helper function for UNOP_ABS. */
-static struct value *
+struct value *
eval_op_f_abs (struct type *expect_type, struct expression *exp,
enum noside noside,
+ enum exp_opcode opcode,
struct value *arg1)
{
if (noside == EVAL_SKIP)
/* A helper function for BINOP_MOD. */
-static struct value *
+struct value *
eval_op_f_mod (struct type *expect_type, struct expression *exp,
enum noside noside,
+ enum exp_opcode opcode,
struct value *arg1, struct value *arg2)
{
if (noside == EVAL_SKIP)
/* A helper function for UNOP_FORTRAN_CEILING. */
-static struct value *
+struct value *
eval_op_f_ceil (struct type *expect_type, struct expression *exp,
enum noside noside,
+ enum exp_opcode opcode,
struct value *arg1)
{
if (noside == EVAL_SKIP)
/* A helper function for UNOP_FORTRAN_FLOOR. */
-static struct value *
+struct value *
eval_op_f_floor (struct type *expect_type, struct expression *exp,
enum noside noside,
+ enum exp_opcode opcode,
struct value *arg1)
{
if (noside == EVAL_SKIP)
return value_from_host_double (type, val);
}
+/* A helper function for BINOP_FORTRAN_MODULO. */
+
+struct value *
+eval_op_f_modulo (struct type *expect_type, struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1, struct value *arg2)
+{
+ if (noside == EVAL_SKIP)
+ return eval_skip_value (exp);
+ struct type *type = value_type (arg1);
+ if (type->code () != value_type (arg2)->code ())
+ error (_("non-matching types for parameters to MODULO ()"));
+ /* MODULO(A, P) = A - FLOOR (A / P) * P */
+ switch (type->code ())
+ {
+ case TYPE_CODE_INT:
+ {
+ LONGEST a = value_as_long (arg1);
+ LONGEST p = value_as_long (arg2);
+ LONGEST result = a - (a / p) * p;
+ if (result != 0 && (a < 0) != (p < 0))
+ result += p;
+ return value_from_longest (value_type (arg1), result);
+ }
+ case TYPE_CODE_FLT:
+ {
+ double a
+ = target_float_to_host_double (value_contents (arg1),
+ value_type (arg1));
+ double p
+ = target_float_to_host_double (value_contents (arg2),
+ value_type (arg2));
+ double result = fmod (a, p);
+ if (result != 0 && (a < 0.0) != (p < 0.0))
+ result += p;
+ return value_from_host_double (type, result);
+ }
+ }
+ error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
+}
+
+/* A helper function for BINOP_FORTRAN_CMPLX. */
+
+struct value *
+eval_op_f_cmplx (struct type *expect_type, struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1, struct value *arg2)
+{
+ if (noside == EVAL_SKIP)
+ return eval_skip_value (exp);
+ struct type *type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
+ return value_literal_complex (arg1, arg2, type);
+}
+
+/* A helper function for UNOP_FORTRAN_KIND. */
+
+struct value *
+eval_op_f_kind (struct type *expect_type, struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1)
+{
+ struct type *type = value_type (arg1);
+
+ switch (type->code ())
+ {
+ case TYPE_CODE_STRUCT:
+ case TYPE_CODE_UNION:
+ case TYPE_CODE_MODULE:
+ case TYPE_CODE_FUNC:
+ error (_("argument to kind must be an intrinsic type"));
+ }
+
+ if (!TYPE_TARGET_TYPE (type))
+ return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
+ TYPE_LENGTH (type));
+ return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
+ TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
+}
+
+/* A helper function for UNOP_FORTRAN_ALLOCATED. */
+
+struct value *
+eval_op_f_allocated (struct type *expect_type, struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1)
+{
+ struct type *type = check_typedef (value_type (arg1));
+ if (type->code () != TYPE_CODE_ARRAY)
+ error (_("ALLOCATED can only be applied to arrays"));
+ struct type *result_type
+ = builtin_f_type (exp->gdbarch)->builtin_logical;
+ LONGEST result_value = type_not_allocated (type) ? 0 : 1;
+ return value_from_longest (result_type, result_value);
+}
+
/* Special expression evaluation cases for Fortran. */
static struct value *
case UNOP_ABS:
arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- return eval_op_f_abs (expect_type, exp, noside, arg1);
+ return eval_op_f_abs (expect_type, exp, noside, op, arg1);
case BINOP_MOD:
arg1 = evaluate_subexp (nullptr, exp, pos, noside);
arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
- return eval_op_f_mod (expect_type, exp, noside, arg1, arg2);
+ return eval_op_f_mod (expect_type, exp, noside, op, arg1, arg2);
case UNOP_FORTRAN_CEILING:
arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- return eval_op_f_ceil (expect_type, exp, noside, arg1);
+ return eval_op_f_ceil (expect_type, exp, noside, op, arg1);
case UNOP_FORTRAN_FLOOR:
arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- return eval_op_f_floor (expect_type, exp, noside, arg1);
+ return eval_op_f_floor (expect_type, exp, noside, op, arg1);
case UNOP_FORTRAN_ALLOCATED:
{
arg1 = evaluate_subexp (nullptr, exp, pos, noside);
if (noside == EVAL_SKIP)
return eval_skip_value (exp);
- type = check_typedef (value_type (arg1));
- if (type->code () != TYPE_CODE_ARRAY)
- error (_("ALLOCATED can only be applied to arrays"));
- struct type *result_type
- = builtin_f_type (exp->gdbarch)->builtin_logical;
- LONGEST result_value = type_not_allocated (type) ? 0 : 1;
- return value_from_longest (result_type, result_value);
+ return eval_op_f_allocated (expect_type, exp, noside, op, arg1);
}
case BINOP_FORTRAN_MODULO:
- {
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- type = value_type (arg1);
- if (type->code () != value_type (arg2)->code ())
- error (_("non-matching types for parameters to MODULO ()"));
- /* MODULO(A, P) = A - FLOOR (A / P) * P */
- switch (type->code ())
- {
- case TYPE_CODE_INT:
- {
- LONGEST a = value_as_long (arg1);
- LONGEST p = value_as_long (arg2);
- LONGEST result = a - (a / p) * p;
- if (result != 0 && (a < 0) != (p < 0))
- result += p;
- return value_from_longest (value_type (arg1), result);
- }
- case TYPE_CODE_FLT:
- {
- double a
- = target_float_to_host_double (value_contents (arg1),
- value_type (arg1));
- double p
- = target_float_to_host_double (value_contents (arg2),
- value_type (arg2));
- double result = fmod (a, p);
- if (result != 0 && (a < 0.0) != (p < 0.0))
- result += p;
- return value_from_host_double (type, result);
- }
- }
- error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
- }
+ arg1 = evaluate_subexp (nullptr, exp, pos, noside);
+ arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
+ return eval_op_f_modulo (expect_type, exp, noside, op, arg1, arg2);
case FORTRAN_LBOUND:
case FORTRAN_UBOUND:
/* Check that the first argument is array like. */
arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- type = check_typedef (value_type (arg1));
- if (type->code () != TYPE_CODE_ARRAY)
- {
- if (lbound_p)
- error (_("LBOUND can only be applied to arrays"));
- else
- error (_("UBOUND can only be applied to arrays"));
- }
+ fortran_require_array (value_type (arg1), lbound_p);
if (nargs == 1)
return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1);
case BINOP_FORTRAN_CMPLX:
arg1 = evaluate_subexp (nullptr, exp, pos, noside);
arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
- return value_literal_complex (arg1, arg2, type);
+ return eval_op_f_cmplx (expect_type, exp, noside, op, arg1, arg2);
case UNOP_FORTRAN_KIND:
arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
- type = value_type (arg1);
-
- switch (type->code ())
- {
- case TYPE_CODE_STRUCT:
- case TYPE_CODE_UNION:
- case TYPE_CODE_MODULE:
- case TYPE_CODE_FUNC:
- error (_("argument to kind must be an intrinsic type"));
- }
-
- if (!TYPE_TARGET_TYPE (type))
- return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
- TYPE_LENGTH (type));
- return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
- TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
-
+ return eval_op_f_kind (expect_type, exp, noside, op, arg1);
case OP_F77_UNDETERMINED_ARGLIST:
/* Remember that in F77, functions, substring ops and array subscript
return nullptr;
}
-/* Special expression lengths for Fortran. */
+namespace expr
+{
-static void
-operator_length_f (const struct expression *exp, int pc, int *oplenp,
- int *argsp)
+/* Called from evaluate to perform array indexing, and sub-range
+ extraction, for Fortran. As well as arrays this function also
+ handles strings as they can be treated like arrays of characters.
+ ARRAY is the array or string being accessed. EXP and NOSIDE are as
+ for evaluate. */
+
+value *
+fortran_undetermined::value_subarray (value *array,
+ struct expression *exp,
+ enum noside noside)
{
- int oplen = 1;
- int args = 0;
+ type *original_array_type = check_typedef (value_type (array));
+ bool is_string_p = original_array_type->code () == TYPE_CODE_STRING;
+ const std::vector<operation_up> &ops = std::get<1> (m_storage);
+ int nargs = ops.size ();
- switch (exp->elts[pc - 1].opcode)
+ /* Perform checks for ARRAY not being available. The somewhat overly
+ complex logic here is just to keep backward compatibility with the
+ errors that we used to get before FORTRAN_VALUE_SUBARRAY was
+ rewritten. Maybe a future task would streamline the error messages we
+ get here, and update all the expected test results. */
+ if (ops[0]->opcode () != OP_RANGE)
{
- default:
- operator_length_standard (exp, pc, oplenp, argsp);
- return;
+ if (type_not_associated (original_array_type))
+ error (_("no such vector element (vector not associated)"));
+ else if (type_not_allocated (original_array_type))
+ error (_("no such vector element (vector not allocated)"));
+ }
+ else
+ {
+ if (type_not_associated (original_array_type))
+ error (_("array not associated"));
+ else if (type_not_allocated (original_array_type))
+ error (_("array not allocated"));
+ }
- case UNOP_FORTRAN_KIND:
- case UNOP_FORTRAN_FLOOR:
- case UNOP_FORTRAN_CEILING:
- case UNOP_FORTRAN_ALLOCATED:
- oplen = 1;
- args = 1;
- break;
+ /* First check that the number of dimensions in the type we are slicing
+ matches the number of arguments we were passed. */
+ int ndimensions = calc_f77_array_dims (original_array_type);
+ if (nargs != ndimensions)
+ error (_("Wrong number of subscripts"));
- case BINOP_FORTRAN_CMPLX:
- case BINOP_FORTRAN_MODULO:
- oplen = 1;
- args = 2;
- break;
+ /* This will be initialised below with the type of the elements held in
+ ARRAY. */
+ struct type *inner_element_type;
- case FORTRAN_ASSOCIATED:
- case FORTRAN_LBOUND:
- case FORTRAN_UBOUND:
- oplen = 3;
- args = longest_to_int (exp->elts[pc - 2].longconst);
- break;
+ /* Extract the types of each array dimension from the original array
+ type. We need these available so we can fill in the default upper and
+ lower bounds if the user requested slice doesn't provide that
+ information. Additionally unpacking the dimensions like this gives us
+ the inner element type. */
+ std::vector<struct type *> dim_types;
+ {
+ dim_types.reserve (ndimensions);
+ struct type *type = original_array_type;
+ for (int i = 0; i < ndimensions; ++i)
+ {
+ dim_types.push_back (type);
+ type = TYPE_TARGET_TYPE (type);
+ }
+ /* TYPE is now the inner element type of the array, we start the new
+ array slice off as this type, then as we process the requested slice
+ (from the user) we wrap new types around this to build up the final
+ slice type. */
+ inner_element_type = type;
+ }
- case OP_F77_UNDETERMINED_ARGLIST:
- oplen = 3;
- args = 1 + longest_to_int (exp->elts[pc - 2].longconst);
- break;
- }
+ /* As we analyse the new slice type we need to understand if the data
+ being referenced is contiguous. Do decide this we must track the size
+ of an element at each dimension of the new slice array. Initially the
+ elements of the inner most dimension of the array are the same inner
+ most elements as the original ARRAY. */
+ LONGEST slice_element_size = TYPE_LENGTH (inner_element_type);
- *oplenp = oplen;
- *argsp = args;
-}
+ /* Start off assuming all data is contiguous, this will be set to false
+ if access to any dimension results in non-contiguous data. */
+ bool is_all_contiguous = true;
-/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
- the extra argument NAME which is the text that should be printed as the
- name of this operation. */
+ /* The TOTAL_OFFSET is the distance in bytes from the start of the
+ original ARRAY to the start of the new slice. This is calculated as
+ we process the information from the user. */
+ LONGEST total_offset = 0;
-static void
-print_unop_subexp_f (struct expression *exp, int *pos,
- struct ui_file *stream, enum precedence prec,
- const char *name)
-{
- (*pos)++;
- fprintf_filtered (stream, "%s(", name);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fputs_filtered (")", stream);
-}
+ /* A structure representing information about each dimension of the
+ resulting slice. */
+ struct slice_dim
+ {
+ /* Constructor. */
+ slice_dim (LONGEST l, LONGEST h, LONGEST s, struct type *idx)
+ : low (l),
+ high (h),
+ stride (s),
+ index (idx)
+ { /* Nothing. */ }
-/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
- the extra argument NAME which is the text that should be printed as the
- name of this operation. */
+ /* The low bound for this dimension of the slice. */
+ LONGEST low;
-static void
-print_binop_subexp_f (struct expression *exp, int *pos,
- struct ui_file *stream, enum precedence prec,
- const char *name)
-{
- (*pos)++;
- fprintf_filtered (stream, "%s(", name);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fputs_filtered (",", stream);
- print_subexp (exp, pos, stream, PREC_SUFFIX);
- fputs_filtered (")", stream);
-}
+ /* The high bound for this dimension of the slice. */
+ LONGEST high;
-/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
- the extra argument NAME which is the text that should be printed as the
- name of this operation. */
+ /* The byte stride for this dimension of the slice. */
+ LONGEST stride;
-static void
-print_unop_or_binop_subexp_f (struct expression *exp, int *pos,
- struct ui_file *stream, enum precedence prec,
- const char *name)
-{
- unsigned nargs = longest_to_int (exp->elts[*pos + 1].longconst);
- (*pos) += 3;
- fprintf_filtered (stream, "%s (", name);
- for (unsigned tem = 0; tem < nargs; tem++)
- {
- if (tem != 0)
- fputs_filtered (", ", stream);
- print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
- }
- fputs_filtered (")", stream);
-}
+ struct type *index;
+ };
-/* Special expression printing for Fortran. */
+ /* The dimensions of the resulting slice. */
+ std::vector<slice_dim> slice_dims;
-static void
-print_subexp_f (struct expression *exp, int *pos,
- struct ui_file *stream, enum precedence prec)
-{
+ /* Process the incoming arguments. These arguments are in the reverse
+ order to the array dimensions, that is the first argument refers to
+ the last array dimension. */
+ if (fortran_array_slicing_debug)
+ debug_printf ("Processing array access:\n");
+ for (int i = 0; i < nargs; ++i)
+ {
+ /* For each dimension of the array the user will have either provided
+ a ranged access with optional lower bound, upper bound, and
+ stride, or the user will have supplied a single index. */
+ struct type *dim_type = dim_types[ndimensions - (i + 1)];
+ fortran_range_operation *range_op
+ = dynamic_cast<fortran_range_operation *> (ops[i].get ());
+ if (range_op != nullptr)
+ {
+ enum range_flag range_flag = range_op->get_flags ();
+
+ LONGEST low, high, stride;
+ low = high = stride = 0;
+
+ if ((range_flag & RANGE_LOW_BOUND_DEFAULT) == 0)
+ low = value_as_long (range_op->evaluate0 (exp, noside));
+ else
+ low = f77_get_lowerbound (dim_type);
+ if ((range_flag & RANGE_HIGH_BOUND_DEFAULT) == 0)
+ high = value_as_long (range_op->evaluate1 (exp, noside));
+ else
+ high = f77_get_upperbound (dim_type);
+ if ((range_flag & RANGE_HAS_STRIDE) == RANGE_HAS_STRIDE)
+ stride = value_as_long (range_op->evaluate2 (exp, noside));
+ else
+ stride = 1;
+
+ if (stride == 0)
+ error (_("stride must not be 0"));
+
+ /* Get information about this dimension in the original ARRAY. */
+ struct type *target_type = TYPE_TARGET_TYPE (dim_type);
+ struct type *index_type = dim_type->index_type ();
+ LONGEST lb = f77_get_lowerbound (dim_type);
+ LONGEST ub = f77_get_upperbound (dim_type);
+ LONGEST sd = index_type->bit_stride ();
+ if (sd == 0)
+ sd = TYPE_LENGTH (target_type) * 8;
+
+ if (fortran_array_slicing_debug)
+ {
+ debug_printf ("|-> Range access\n");
+ std::string str = type_to_string (dim_type);
+ debug_printf ("| |-> Type: %s\n", str.c_str ());
+ debug_printf ("| |-> Array:\n");
+ debug_printf ("| | |-> Low bound: %s\n", plongest (lb));
+ debug_printf ("| | |-> High bound: %s\n", plongest (ub));
+ debug_printf ("| | |-> Bit stride: %s\n", plongest (sd));
+ debug_printf ("| | |-> Byte stride: %s\n", plongest (sd / 8));
+ debug_printf ("| | |-> Type size: %s\n",
+ pulongest (TYPE_LENGTH (dim_type)));
+ debug_printf ("| | '-> Target type size: %s\n",
+ pulongest (TYPE_LENGTH (target_type)));
+ debug_printf ("| |-> Accessing:\n");
+ debug_printf ("| | |-> Low bound: %s\n",
+ plongest (low));
+ debug_printf ("| | |-> High bound: %s\n",
+ plongest (high));
+ debug_printf ("| | '-> Element stride: %s\n",
+ plongest (stride));
+ }
+
+ /* Check the user hasn't asked for something invalid. */
+ if (high > ub || low < lb)
+ error (_("array subscript out of bounds"));
+
+ /* Calculate what this dimension of the new slice array will look
+ like. OFFSET is the byte offset from the start of the
+ previous (more outer) dimension to the start of this
+ dimension. E_COUNT is the number of elements in this
+ dimension. REMAINDER is the number of elements remaining
+ between the last included element and the upper bound. For
+ example an access '1:6:2' will include elements 1, 3, 5 and
+ have a remainder of 1 (element #6). */
+ LONGEST lowest = std::min (low, high);
+ LONGEST offset = (sd / 8) * (lowest - lb);
+ LONGEST e_count = std::abs (high - low) + 1;
+ e_count = (e_count + (std::abs (stride) - 1)) / std::abs (stride);
+ LONGEST new_low = 1;
+ LONGEST new_high = new_low + e_count - 1;
+ LONGEST new_stride = (sd * stride) / 8;
+ LONGEST last_elem = low + ((e_count - 1) * stride);
+ LONGEST remainder = high - last_elem;
+ if (low > high)
+ {
+ offset += std::abs (remainder) * TYPE_LENGTH (target_type);
+ if (stride > 0)
+ error (_("incorrect stride and boundary combination"));
+ }
+ else if (stride < 0)
+ error (_("incorrect stride and boundary combination"));
+
+ /* Is the data within this dimension contiguous? It is if the
+ newly computed stride is the same size as a single element of
+ this dimension. */
+ bool is_dim_contiguous = (new_stride == slice_element_size);
+ is_all_contiguous &= is_dim_contiguous;
+
+ if (fortran_array_slicing_debug)
+ {
+ debug_printf ("| '-> Results:\n");
+ debug_printf ("| |-> Offset = %s\n", plongest (offset));
+ debug_printf ("| |-> Elements = %s\n", plongest (e_count));
+ debug_printf ("| |-> Low bound = %s\n", plongest (new_low));
+ debug_printf ("| |-> High bound = %s\n",
+ plongest (new_high));
+ debug_printf ("| |-> Byte stride = %s\n",
+ plongest (new_stride));
+ debug_printf ("| |-> Last element = %s\n",
+ plongest (last_elem));
+ debug_printf ("| |-> Remainder = %s\n",
+ plongest (remainder));
+ debug_printf ("| '-> Contiguous = %s\n",
+ (is_dim_contiguous ? "Yes" : "No"));
+ }
+
+ /* Figure out how big (in bytes) an element of this dimension of
+ the new array slice will be. */
+ slice_element_size = std::abs (new_stride * e_count);
+
+ slice_dims.emplace_back (new_low, new_high, new_stride,
+ index_type);
+
+ /* Update the total offset. */
+ total_offset += offset;
+ }
+ else
+ {
+ /* There is a single index for this dimension. */
+ LONGEST index
+ = value_as_long (ops[i]->evaluate_with_coercion (exp, noside));
+
+ /* Get information about this dimension in the original ARRAY. */
+ struct type *target_type = TYPE_TARGET_TYPE (dim_type);
+ struct type *index_type = dim_type->index_type ();
+ LONGEST lb = f77_get_lowerbound (dim_type);
+ LONGEST ub = f77_get_upperbound (dim_type);
+ LONGEST sd = index_type->bit_stride () / 8;
+ if (sd == 0)
+ sd = TYPE_LENGTH (target_type);
+
+ if (fortran_array_slicing_debug)
+ {
+ debug_printf ("|-> Index access\n");
+ std::string str = type_to_string (dim_type);
+ debug_printf ("| |-> Type: %s\n", str.c_str ());
+ debug_printf ("| |-> Array:\n");
+ debug_printf ("| | |-> Low bound: %s\n", plongest (lb));
+ debug_printf ("| | |-> High bound: %s\n", plongest (ub));
+ debug_printf ("| | |-> Byte stride: %s\n", plongest (sd));
+ debug_printf ("| | |-> Type size: %s\n",
+ pulongest (TYPE_LENGTH (dim_type)));
+ debug_printf ("| | '-> Target type size: %s\n",
+ pulongest (TYPE_LENGTH (target_type)));
+ debug_printf ("| '-> Accessing:\n");
+ debug_printf ("| '-> Index: %s\n",
+ plongest (index));
+ }
+
+ /* If the array has actual content then check the index is in
+ bounds. An array without content (an unbound array) doesn't
+ have a known upper bound, so don't error check in that
+ situation. */
+ if (index < lb
+ || (dim_type->index_type ()->bounds ()->high.kind () != PROP_UNDEFINED
+ && index > ub)
+ || (VALUE_LVAL (array) != lval_memory
+ && dim_type->index_type ()->bounds ()->high.kind () == PROP_UNDEFINED))
+ {
+ if (type_not_associated (dim_type))
+ error (_("no such vector element (vector not associated)"));
+ else if (type_not_allocated (dim_type))
+ error (_("no such vector element (vector not allocated)"));
+ else
+ error (_("no such vector element"));
+ }
+
+ /* Calculate using the type stride, not the target type size. */
+ LONGEST offset = sd * (index - lb);
+ total_offset += offset;
+ }
+ }
+
+ /* Build a type that represents the new array slice in the target memory
+ of the original ARRAY, this type makes use of strides to correctly
+ find only those elements that are part of the new slice. */
+ struct type *array_slice_type = inner_element_type;
+ for (const auto &d : slice_dims)
+ {
+ /* Create the range. */
+ dynamic_prop p_low, p_high, p_stride;
+
+ p_low.set_const_val (d.low);
+ p_high.set_const_val (d.high);
+ p_stride.set_const_val (d.stride);
+
+ struct type *new_range
+ = create_range_type_with_stride ((struct type *) NULL,
+ TYPE_TARGET_TYPE (d.index),
+ &p_low, &p_high, 0, &p_stride,
+ true);
+ array_slice_type
+ = create_array_type (nullptr, array_slice_type, new_range);
+ }
+
+ if (fortran_array_slicing_debug)
+ {
+ debug_printf ("'-> Final result:\n");
+ debug_printf (" |-> Type: %s\n",
+ type_to_string (array_slice_type).c_str ());
+ debug_printf (" |-> Total offset: %s\n",
+ plongest (total_offset));
+ debug_printf (" |-> Base address: %s\n",
+ core_addr_to_string (value_address (array)));
+ debug_printf (" '-> Contiguous = %s\n",
+ (is_all_contiguous ? "Yes" : "No"));
+ }
+
+ /* Should we repack this array slice? */
+ if (!is_all_contiguous && (repack_array_slices || is_string_p))
+ {
+ /* Build a type for the repacked slice. */
+ struct type *repacked_array_type = inner_element_type;
+ for (const auto &d : slice_dims)
+ {
+ /* Create the range. */
+ dynamic_prop p_low, p_high, p_stride;
+
+ p_low.set_const_val (d.low);
+ p_high.set_const_val (d.high);
+ p_stride.set_const_val (TYPE_LENGTH (repacked_array_type));
+
+ struct type *new_range
+ = create_range_type_with_stride ((struct type *) NULL,
+ TYPE_TARGET_TYPE (d.index),
+ &p_low, &p_high, 0, &p_stride,
+ true);
+ repacked_array_type
+ = create_array_type (nullptr, repacked_array_type, new_range);
+ }
+
+ /* Now copy the elements from the original ARRAY into the packed
+ array value DEST. */
+ struct value *dest = allocate_value (repacked_array_type);
+ if (value_lazy (array)
+ || (total_offset + TYPE_LENGTH (array_slice_type)
+ > TYPE_LENGTH (check_typedef (value_type (array)))))
+ {
+ fortran_array_walker<fortran_lazy_array_repacker_impl> p
+ (array_slice_type, value_address (array) + total_offset, dest);
+ p.walk ();
+ }
+ else
+ {
+ fortran_array_walker<fortran_array_repacker_impl> p
+ (array_slice_type, value_address (array) + total_offset,
+ total_offset, array, dest);
+ p.walk ();
+ }
+ array = dest;
+ }
+ else
+ {
+ if (VALUE_LVAL (array) == lval_memory)
+ {
+ /* If the value we're taking a slice from is not yet loaded, or
+ the requested slice is outside the values content range then
+ just create a new lazy value pointing at the memory where the
+ contents we're looking for exist. */
+ if (value_lazy (array)
+ || (total_offset + TYPE_LENGTH (array_slice_type)
+ > TYPE_LENGTH (check_typedef (value_type (array)))))
+ array = value_at_lazy (array_slice_type,
+ value_address (array) + total_offset);
+ else
+ array = value_from_contents_and_address (array_slice_type,
+ (value_contents (array)
+ + total_offset),
+ (value_address (array)
+ + total_offset));
+ }
+ else if (!value_lazy (array))
+ array = value_from_component (array, array_slice_type, total_offset);
+ else
+ error (_("cannot subscript arrays that are not in memory"));
+ }
+
+ return array;
+}
+
+value *
+fortran_undetermined::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ value *callee = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
+ struct type *type = check_typedef (value_type (callee));
+ enum type_code code = type->code ();
+
+ if (code == TYPE_CODE_PTR)
+ {
+ /* Fortran always passes variable to subroutines as pointer.
+ So we need to look into its target type to see if it is
+ array, string or function. If it is, we need to switch
+ to the target value the original one points to. */
+ struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
+
+ if (target_type->code () == TYPE_CODE_ARRAY
+ || target_type->code () == TYPE_CODE_STRING
+ || target_type->code () == TYPE_CODE_FUNC)
+ {
+ callee = value_ind (callee);
+ type = check_typedef (value_type (callee));
+ code = type->code ();
+ }
+ }
+
+ switch (code)
+ {
+ case TYPE_CODE_ARRAY:
+ case TYPE_CODE_STRING:
+ return value_subarray (callee, exp, noside);
+
+ case TYPE_CODE_PTR:
+ case TYPE_CODE_FUNC:
+ case TYPE_CODE_INTERNAL_FUNCTION:
+ {
+ /* It's a function call. Allocate arg vector, including
+ space for the function to be called in argvec[0] and a
+ termination NULL. */
+ const std::vector<operation_up> &actual (std::get<1> (m_storage));
+ std::vector<value *> argvec (actual.size ());
+ bool is_internal_func = (code == TYPE_CODE_INTERNAL_FUNCTION);
+ for (int tem = 0; tem < argvec.size (); tem++)
+ argvec[tem] = fortran_prepare_argument (exp, actual[tem].get (),
+ tem, is_internal_func,
+ value_type (callee),
+ noside);
+ return evaluate_subexp_do_call (exp, noside, callee, argvec,
+ nullptr, expect_type);
+ }
+
+ default:
+ error (_("Cannot perform substring on this type"));
+ }
+}
+
+value *
+fortran_bound_1arg::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
+ value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
+ fortran_require_array (value_type (arg1), lbound_p);
+ return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1);
+}
+
+value *
+fortran_bound_2arg::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
+{
+ bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
+ value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
+ fortran_require_array (value_type (arg1), lbound_p);
+
+ /* User asked for the bounds of a specific dimension of the array. */
+ value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
+ struct type *type = check_typedef (value_type (arg2));
+ if (type->code () != TYPE_CODE_INT)
+ {
+ if (lbound_p)
+ error (_("LBOUND second argument should be an integer"));
+ else
+ error (_("UBOUND second argument should be an integer"));
+ }
+
+ return fortran_bounds_for_dimension (lbound_p, exp->gdbarch, arg1, arg2);
+}
+
+} /* namespace expr */
+
+/* Special expression lengths for Fortran. */
+
+static void
+operator_length_f (const struct expression *exp, int pc, int *oplenp,
+ int *argsp)
+{
+ int oplen = 1;
+ int args = 0;
+
+ switch (exp->elts[pc - 1].opcode)
+ {
+ default:
+ operator_length_standard (exp, pc, oplenp, argsp);
+ return;
+
+ case UNOP_FORTRAN_KIND:
+ case UNOP_FORTRAN_FLOOR:
+ case UNOP_FORTRAN_CEILING:
+ case UNOP_FORTRAN_ALLOCATED:
+ oplen = 1;
+ args = 1;
+ break;
+
+ case BINOP_FORTRAN_CMPLX:
+ case BINOP_FORTRAN_MODULO:
+ oplen = 1;
+ args = 2;
+ break;
+
+ case FORTRAN_ASSOCIATED:
+ case FORTRAN_LBOUND:
+ case FORTRAN_UBOUND:
+ oplen = 3;
+ args = longest_to_int (exp->elts[pc - 2].longconst);
+ break;
+
+ case OP_F77_UNDETERMINED_ARGLIST:
+ oplen = 3;
+ args = 1 + longest_to_int (exp->elts[pc - 2].longconst);
+ break;
+ }
+
+ *oplenp = oplen;
+ *argsp = args;
+}
+
+/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
+ the extra argument NAME which is the text that should be printed as the
+ name of this operation. */
+
+static void
+print_unop_subexp_f (struct expression *exp, int *pos,
+ struct ui_file *stream, enum precedence prec,
+ const char *name)
+{
+ (*pos)++;
+ fprintf_filtered (stream, "%s(", name);
+ print_subexp (exp, pos, stream, PREC_SUFFIX);
+ fputs_filtered (")", stream);
+}
+
+/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
+ the extra argument NAME which is the text that should be printed as the
+ name of this operation. */
+
+static void
+print_binop_subexp_f (struct expression *exp, int *pos,
+ struct ui_file *stream, enum precedence prec,
+ const char *name)
+{
+ (*pos)++;
+ fprintf_filtered (stream, "%s(", name);
+ print_subexp (exp, pos, stream, PREC_SUFFIX);
+ fputs_filtered (",", stream);
+ print_subexp (exp, pos, stream, PREC_SUFFIX);
+ fputs_filtered (")", stream);
+}
+
+/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
+ the extra argument NAME which is the text that should be printed as the
+ name of this operation. */
+
+static void
+print_unop_or_binop_subexp_f (struct expression *exp, int *pos,
+ struct ui_file *stream, enum precedence prec,
+ const char *name)
+{
+ unsigned nargs = longest_to_int (exp->elts[*pos + 1].longconst);
+ (*pos) += 3;
+ fprintf_filtered (stream, "%s (", name);
+ for (unsigned tem = 0; tem < nargs; tem++)
+ {
+ if (tem != 0)
+ fputs_filtered (", ", stream);
+ print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
+ }
+ fputs_filtered (")", stream);
+}
+
+/* Special expression printing for Fortran. */
+
+static void
+print_subexp_f (struct expression *exp, int *pos,
+ struct ui_file *stream, enum precedence prec)
+{
int pc = *pos;
enum exp_opcode op = exp->elts[pc].opcode;
return fortran_argument_convert (arg_val, is_artificial);
}
+/* Prepare (and return) an argument value ready for an inferior function
+ call to a Fortran function. EXP and POS are the expressions describing
+ the argument to prepare. ARG_NUM is the argument number being
+ prepared, with 0 being the first argument and so on. FUNC_TYPE is the
+ type of the function being called.
+
+ IS_INTERNAL_CALL_P is true if this is a call to a function of type
+ TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
+
+ NOSIDE has its usual meaning for expression parsing (see eval.c).
+
+ Arguments in Fortran are normally passed by address, we coerce the
+ arguments here rather than in value_arg_coerce as otherwise the call to
+ malloc (to place the non-lvalue parameters in target memory) is hit by
+ this Fortran specific logic. This results in malloc being called with a
+ pointer to an integer followed by an attempt to malloc the arguments to
+ malloc in target memory. Infinite recursion ensues. */
+
+static value *
+fortran_prepare_argument (struct expression *exp,
+ expr::operation *subexp,
+ int arg_num, bool is_internal_call_p,
+ struct type *func_type, enum noside noside)
+{
+ if (is_internal_call_p)
+ return subexp->evaluate_with_coercion (exp, noside);
+
+ bool is_artificial = ((arg_num >= func_type->num_fields ())
+ ? true
+ : TYPE_FIELD_ARTIFICIAL (func_type, arg_num));
+
+ /* If this is an artificial argument, then either, this is an argument
+ beyond the end of the known arguments, or possibly, there are no known
+ arguments (maybe missing debug info).
+
+ For these artificial arguments, if the user has prefixed it with '&'
+ (for address-of), then lets always allow this to succeed, even if the
+ argument is not actually in inferior memory. This will allow the user
+ to pass arguments to a Fortran function even when there's no debug
+ information.
+
+ As we already pass the address of non-artificial arguments, all we
+ need to do if skip the UNOP_ADDR operator in the expression and mark
+ the argument as non-artificial. */
+ if (is_artificial)
+ {
+ expr::unop_addr_operation *addrop
+ = dynamic_cast<expr::unop_addr_operation *> (subexp);
+ if (addrop != nullptr)
+ {
+ subexp = addrop->get_expression ().get ();
+ is_artificial = false;
+ }
+ }
+
+ struct value *arg_val = subexp->evaluate_with_coercion (exp, noside);
+ return fortran_argument_convert (arg_val, is_artificial);
+}
+
/* See f-lang.h. */
struct type *
projects / deliverable / binutils-gdb.git / blobdiff