/* Fortran language support routines for GDB, the GNU debugger.
- Copyright (C) 1993-2021 Free Software Foundation, Inc.
+ Copyright (C) 1993-2022 Free Software Foundation, Inc.
Contributed by Motorola. Adapted from the C parser by Farooq Butt
(fmbutt@engage.sps.mot.com).
show_repack_array_slices (struct ui_file *file, int from_tty,
struct cmd_list_element *c, const char *value)
{
- fprintf_filtered (file, _("Repacking of Fortran array slices is %s.\n"),
- value);
+ gdb_printf (file, _("Repacking of Fortran array slices is %s.\n"),
+ value);
}
/* Debugging of Fortran's array slicing. */
struct cmd_list_element *c,
const char *value)
{
- fprintf_filtered (file, _("Debugging of Fortran array slicing is %s.\n"),
- value);
+ gdb_printf (file, _("Debugging of Fortran array slicing is %s.\n"),
+ value);
}
/* Local functions */
-static value *fortran_prepare_argument (struct expression *exp, int *pos,
- 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,
return encoding;
}
-\f
-
-/* Table of operators and their precedences for printing expressions. */
-
-const struct op_print f_language::op_print_tab[] =
-{
- {"+", BINOP_ADD, PREC_ADD, 0},
- {"+", UNOP_PLUS, PREC_PREFIX, 0},
- {"-", BINOP_SUB, PREC_ADD, 0},
- {"-", UNOP_NEG, PREC_PREFIX, 0},
- {"*", BINOP_MUL, PREC_MUL, 0},
- {"/", BINOP_DIV, PREC_MUL, 0},
- {"DIV", BINOP_INTDIV, PREC_MUL, 0},
- {"MOD", BINOP_REM, PREC_MUL, 0},
- {"=", BINOP_ASSIGN, PREC_ASSIGN, 1},
- {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
- {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
- {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
- {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0},
- {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0},
- {".LE.", BINOP_LEQ, PREC_ORDER, 0},
- {".GE.", BINOP_GEQ, PREC_ORDER, 0},
- {".GT.", BINOP_GTR, PREC_ORDER, 0},
- {".LT.", BINOP_LESS, PREC_ORDER, 0},
- {"**", UNOP_IND, PREC_PREFIX, 0},
- {"@", BINOP_REPEAT, PREC_REPEAT, 0},
- {NULL, OP_NULL, PREC_REPEAT, 0}
-};
-\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. */
/* Allocate a result value of the correct type. */
struct type *range
= create_static_range_type (nullptr,
- builtin_type (gdbarch)->builtin_int,
+ builtin_f_type (gdbarch)->builtin_integer,
1, ndimensions);
- struct type *elm_type = builtin_type (gdbarch)->builtin_long_long;
+ struct type *elm_type = builtin_f_type (gdbarch)->builtin_integer;
struct type *result_type = create_array_type (nullptr, elm_type, range);
struct value *result = allocate_value (result_type);
/* Return the lower bound (when LBOUND_P is true) or the upper bound (when
LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
- ARRAY (which must be an array). GDBARCH is the current architecture. */
+ ARRAY (which must be an array). RESULT_TYPE corresponds to the type kind
+ the function should be evaluated in. */
-static struct value *
-fortran_bounds_for_dimension (bool lbound_p,
- struct gdbarch *gdbarch,
- struct value *array,
- struct value *dim_val)
+static value *
+fortran_bounds_for_dimension (bool lbound_p, value *array, value *dim_val,
+ type* result_type)
{
/* Check the requested dimension is valid for this array. */
type *array_type = check_typedef (value_type (array));
error (_("UBOUND dimension must be from 1 to %d"), ndimensions);
}
- /* The type for the result. */
- struct type *bound_type = builtin_type (gdbarch)->builtin_long_long;
-
/* Walk the dimensions backwards, due to the ordering in which arrays are
laid out the first dimension is the most inner. */
for (int i = ndimensions - 1; i >= 0; --i)
else
b = f77_get_upperbound (array_type);
- return value_from_longest (bound_type, b);
+ return value_from_longest (result_type, b);
}
/* Peel off another dimension of the array. */
gdb_assert_not_reached ("failed to find matching dimension");
}
-\f
/* Return the number of dimensions for a Fortran array or string. */
will be creating values for each element as we load them and then copy
them into the M_DEST value. Set a value mark so we can free these
temporary values. */
- void start_dimension (bool inner_p)
+ void start_dimension (struct type *index_type, LONGEST nelts, bool inner_p)
{
if (inner_p)
{
/* Create a lazy value in target memory representing a single element,
then load the element into GDB's memory and copy the contents into the
destination value. */
- void process_element (struct type *elt_type, LONGEST elt_off, bool last_p)
+ void process_element (struct type *elt_type, LONGEST elt_off,
+ LONGEST index, bool last_p)
{
copy_element_to_dest (value_at_lazy (elt_type, m_addr + elt_off));
}
/* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
from the content buffer of M_VAL then copy this extracted value into
the repacked destination value. */
- void process_element (struct type *elt_type, LONGEST elt_off, bool last_p)
+ void process_element (struct type *elt_type, LONGEST elt_off,
+ LONGEST index, bool last_p)
{
struct value *elt
= value_from_component (m_val, elt_type, (elt_off + m_base_offset));
struct value *m_val;
};
-/* Called from evaluate_subexp_standard 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, POS, and NOSIDE are
- as for evaluate_subexp_standard, and NARGS is the number of arguments
- in this access (e.g. 'array (1,2,3)' would be NARGS 3). */
-
-static struct value *
-fortran_value_subarray (struct value *array, struct expression *exp,
- int *pos, int nargs, enum noside noside)
-{
- type *original_array_type = check_typedef (value_type (array));
- bool is_string_p = original_array_type->code () == TYPE_CODE_STRING;
-
- /* 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 (exp->elts[*pos].opcode != OP_RANGE)
- {
- 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"));
- }
-
- /* 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"));
-
- /* This will be initialised below with the type of the elements held in
- ARRAY. */
- struct type *inner_element_type;
-
- /* 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;
- }
-
- /* 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);
-
- /* 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;
-
- /* 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;
-
- /* 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. */ }
-
- /* The low bound for this dimension of the slice. */
- LONGEST low;
-
- /* The high bound for this dimension of the slice. */
- LONGEST high;
-
- /* The byte stride for this dimension of the slice. */
- LONGEST stride;
-
- struct type *index;
- };
-
- /* The dimensions of the resulting slice. */
- std::vector<slice_dim> slice_dims;
-
- /* 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)];
- if (exp->elts[*pos].opcode == OP_RANGE)
- {
- int pc = (*pos) + 1;
- enum range_flag range_flag = (enum range_flag) exp->elts[pc].longconst;
- *pos += 3;
-
- LONGEST low, high, stride;
- low = high = stride = 0;
-
- if ((range_flag & RANGE_LOW_BOUND_DEFAULT) == 0)
- low = value_as_long (evaluate_subexp (nullptr, exp, pos, noside));
- else
- low = f77_get_lowerbound (dim_type);
- if ((range_flag & RANGE_HIGH_BOUND_DEFAULT) == 0)
- high = value_as_long (evaluate_subexp (nullptr, exp, pos, noside));
- else
- high = f77_get_upperbound (dim_type);
- if ((range_flag & RANGE_HAS_STRIDE) == RANGE_HAS_STRIDE)
- stride = value_as_long (evaluate_subexp (nullptr, exp, pos, 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 (evaluate_subexp_with_coercion (exp, pos, 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;
- }
- }
-
- if (noside == EVAL_SKIP)
- return array;
-
- /* 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;
-}
/* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
extracted from the expression being evaluated. POINTER is the required
if (dim < pointer_dims)
break;
- is_associated = true;
+ is_associated = true;
+ }
+ while (false);
+
+ 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);
+}
+
+/* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE'
+ keyword. RESULT_TYPE corresponds to the type kind the function should be
+ evaluated in, ARRAY is the value that should be an array, though this will
+ not have been checked before calling this function. DIM is optional, if
+ present then it should be an integer identifying a dimension of the
+ array to ask about. As with ARRAY the validity of DIM is not checked
+ before calling this function.
+
+ Return either the total number of elements in ARRAY (when DIM is
+ nullptr), or the number of elements in dimension DIM. */
+
+static value *
+fortran_array_size (value *array, value *dim_val, type *result_type)
+{
+ /* Check that ARRAY is the correct type. */
+ struct type *array_type = check_typedef (value_type (array));
+ if (array_type->code () != TYPE_CODE_ARRAY)
+ error (_("SIZE can only be applied to arrays"));
+ if (type_not_allocated (array_type) || type_not_associated (array_type))
+ error (_("SIZE can only be used on allocated/associated arrays"));
+
+ int ndimensions = calc_f77_array_dims (array_type);
+ int dim = -1;
+ LONGEST result = 0;
+
+ if (dim_val != nullptr)
+ {
+ if (check_typedef (value_type (dim_val))->code () != TYPE_CODE_INT)
+ error (_("DIM argument to SIZE must be an integer"));
+ dim = (int) value_as_long (dim_val);
+
+ if (dim < 1 || dim > ndimensions)
+ error (_("DIM argument to SIZE must be between 1 and %d"),
+ ndimensions);
+ }
+
+ /* Now walk over all the dimensions of the array totalling up the
+ elements in each dimension. */
+ for (int i = ndimensions - 1; i >= 0; --i)
+ {
+ /* If this is the requested dimension then we're done. Grab the
+ bounds and return. */
+ if (i == dim - 1 || dim == -1)
+ {
+ LONGEST lbound, ubound;
+ struct type *range = array_type->index_type ();
+
+ if (!get_discrete_bounds (range, &lbound, &ubound))
+ error (_("failed to find array bounds"));
+
+ LONGEST dim_size = (ubound - lbound + 1);
+ if (result == 0)
+ result = dim_size;
+ else
+ result *= dim_size;
+
+ if (dim != -1)
+ break;
+ }
+
+ /* Peel off another dimension of the array. */
+ array_type = TYPE_TARGET_TYPE (array_type);
+ }
+
+ return value_from_longest (result_type, result);
+}
+
+/* See f-exp.h. */
+
+struct value *
+eval_op_f_array_size (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1)
+{
+ gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
+
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_array_size (arg1, nullptr, result_type);
+}
+
+/* See f-exp.h. */
+
+struct value *
+eval_op_f_array_size (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1,
+ struct value *arg2)
+{
+ gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
+
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_array_size (arg1, arg2, result_type);
+}
+
+/* See f-exp.h. */
+
+value *eval_op_f_array_size (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1, value *arg2,
+ type *kind_arg)
+{
+ gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
+ gdb_assert (kind_arg->code () == TYPE_CODE_INT);
+
+ return fortran_array_size (arg1, arg2, kind_arg);
+}
+
+/* Implement UNOP_FORTRAN_SHAPE expression. Both GDBARCH and LANG are
+ extracted from the expression being evaluated. VAL is the value on
+ which 'shape' was used, this can be any type.
+
+ Return an array of integers. If VAL is not an array then the returned
+ array should have zero elements. If VAL is an array then the returned
+ array should have one element per dimension, with the element
+ containing the extent of that dimension from VAL. */
+
+static struct value *
+fortran_array_shape (struct gdbarch *gdbarch, const language_defn *lang,
+ struct value *val)
+{
+ struct type *val_type = check_typedef (value_type (val));
+
+ /* If we are passed an array that is either not allocated, or not
+ associated, then this is explicitly not allowed according to the
+ Fortran specification. */
+ if (val_type->code () == TYPE_CODE_ARRAY
+ && (type_not_associated (val_type) || type_not_allocated (val_type)))
+ error (_("The array passed to SHAPE must be allocated or associated"));
+
+ /* The Fortran specification allows non-array types to be passed to this
+ function, in which case we get back an empty array.
+
+ Calculate the number of dimensions for the resulting array. */
+ int ndimensions = 0;
+ if (val_type->code () == TYPE_CODE_ARRAY)
+ ndimensions = calc_f77_array_dims (val_type);
+
+ /* Allocate a result value of the correct type. */
+ struct type *range
+ = create_static_range_type (nullptr,
+ builtin_type (gdbarch)->builtin_int,
+ 1, ndimensions);
+ struct type *elm_type = builtin_f_type (gdbarch)->builtin_integer;
+ struct type *result_type = create_array_type (nullptr, elm_type, range);
+ struct value *result = allocate_value (result_type);
+ LONGEST elm_len = TYPE_LENGTH (elm_type);
+
+ /* Walk the array dimensions backwards due to the way the array will be
+ laid out in memory, the first dimension will be the most inner.
+
+ If VAL was not an array then ndimensions will be 0, in which case we
+ will never go around this loop. */
+ for (LONGEST dst_offset = elm_len * (ndimensions - 1);
+ dst_offset >= 0;
+ dst_offset -= elm_len)
+ {
+ LONGEST lbound, ubound;
+
+ if (!get_discrete_bounds (val_type->index_type (), &lbound, &ubound))
+ error (_("failed to find array bounds"));
+
+ LONGEST dim_size = (ubound - lbound + 1);
+
+ /* And copy the value into the result value. */
+ struct value *v = value_from_longest (elm_type, dim_size);
+ gdb_assert (dst_offset + TYPE_LENGTH (value_type (v))
+ <= TYPE_LENGTH (value_type (result)));
+ gdb_assert (TYPE_LENGTH (value_type (v)) == elm_len);
+ value_contents_copy (result, dst_offset, v, 0, elm_len);
+
+ /* Peel another dimension of the array. */
+ val_type = TYPE_TARGET_TYPE (val_type);
}
- while (false);
- return value_from_longest (result_type, is_associated ? 1 : 0);
+ return result;
}
-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);
-}
+/* See f-exp.h. */
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)
+eval_op_f_array_shape (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, arg2);
+ gdb_assert (opcode == UNOP_FORTRAN_SHAPE);
+ return fortran_array_shape (exp->gdbarch, exp->language_defn, arg1);
}
/* A helper function for UNOP_ABS. */
enum exp_opcode opcode,
struct value *arg1)
{
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
struct type *type = value_type (arg1);
switch (type->code ())
{
case TYPE_CODE_FLT:
{
double d
- = fabs (target_float_to_host_double (value_contents (arg1),
+ = fabs (target_float_to_host_double (value_contents (arg1).data (),
value_type (arg1)));
return value_from_host_double (type, d);
}
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 MOD ()"));
case TYPE_CODE_FLT:
{
double d1
- = target_float_to_host_double (value_contents (arg1),
+ = target_float_to_host_double (value_contents (arg1).data (),
value_type (arg1));
double d2
- = target_float_to_host_double (value_contents (arg2),
+ = target_float_to_host_double (value_contents (arg2).data (),
value_type (arg2));
double d3 = fmod (d1, d2);
return value_from_host_double (type, d3);
error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
}
-/* A helper function for UNOP_FORTRAN_CEILING. */
+/* A helper function for the different FORTRAN_CEILING overloads. Calculates
+ CEILING for ARG1 (a float type) and returns it in the requested kind type
+ RESULT_TYPE. */
+
+static value *
+fortran_ceil_operation (value *arg1, type *result_type)
+{
+ if (value_type (arg1)->code () != TYPE_CODE_FLT)
+ error (_("argument to CEILING must be of type float"));
+ double val = target_float_to_host_double (value_contents (arg1).data (),
+ value_type (arg1));
+ val = ceil (val);
+ return value_from_longest (result_type, val);
+}
+
+/* A helper function for FORTRAN_CEILING. */
struct value *
eval_op_f_ceil (struct type *expect_type, struct expression *exp,
enum exp_opcode opcode,
struct value *arg1)
{
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- struct type *type = value_type (arg1);
- if (type->code () != TYPE_CODE_FLT)
- error (_("argument to CEILING must be of type float"));
- double val
- = target_float_to_host_double (value_contents (arg1),
- value_type (arg1));
- val = ceil (val);
- return value_from_host_double (type, val);
+ gdb_assert (opcode == FORTRAN_CEILING);
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_ceil_operation (arg1, result_type);
}
-/* A helper function for UNOP_FORTRAN_FLOOR. */
+/* A helper function for FORTRAN_CEILING. */
-struct value *
-eval_op_f_floor (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1)
+value *
+eval_op_f_ceil (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1, type *kind_arg)
{
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- struct type *type = value_type (arg1);
- if (type->code () != TYPE_CODE_FLT)
+ gdb_assert (opcode == FORTRAN_CEILING);
+ gdb_assert (kind_arg->code () == TYPE_CODE_INT);
+ return fortran_ceil_operation (arg1, kind_arg);
+}
+
+/* A helper function for the different FORTRAN_FLOOR overloads. Calculates
+ FLOOR for ARG1 (a float type) and returns it in the requested kind type
+ RESULT_TYPE. */
+
+static value *
+fortran_floor_operation (value *arg1, type *result_type)
+{
+ if (value_type (arg1)->code () != TYPE_CODE_FLT)
error (_("argument to FLOOR must be of type float"));
- double val
- = target_float_to_host_double (value_contents (arg1),
- value_type (arg1));
+ double val = target_float_to_host_double (value_contents (arg1).data (),
+ value_type (arg1));
val = floor (val);
- return value_from_host_double (type, val);
+ return value_from_longest (result_type, val);
+}
+
+/* A helper function for FORTRAN_FLOOR. */
+
+struct value *
+eval_op_f_floor (struct type *expect_type, struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1)
+{
+ gdb_assert (opcode == FORTRAN_FLOOR);
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_floor_operation (arg1, result_type);
+}
+
+/* A helper function for FORTRAN_FLOOR. */
+
+struct value *
+eval_op_f_floor (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1, type *kind_arg)
+{
+ gdb_assert (opcode == FORTRAN_FLOOR);
+ gdb_assert (kind_arg->code () == TYPE_CODE_INT);
+ return fortran_floor_operation (arg1, kind_arg);
}
/* A helper function for BINOP_FORTRAN_MODULO. */
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 ()"));
case TYPE_CODE_FLT:
{
double a
- = target_float_to_host_double (value_contents (arg1),
+ = target_float_to_host_double (value_contents (arg1).data (),
value_type (arg1));
double p
- = target_float_to_host_double (value_contents (arg2),
+ = target_float_to_host_double (value_contents (arg2).data (),
value_type (arg2));
double result = fmod (a, p);
if (result != 0 && (a < 0.0) != (p < 0.0))
error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
}
-/* A helper function for BINOP_FORTRAN_CMPLX. */
+/* A helper function for FORTRAN_CMPLX. */
+
+value *
+eval_op_f_cmplx (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1)
+{
+ gdb_assert (opcode == FORTRAN_CMPLX);
+
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_complex;
+
+ if (value_type (arg1)->code () == TYPE_CODE_COMPLEX)
+ return value_cast (result_type, arg1);
+ else
+ return value_literal_complex (arg1,
+ value_zero (value_type (arg1), not_lval),
+ result_type);
+}
+
+/* A helper function for FORTRAN_CMPLX. */
struct value *
eval_op_f_cmplx (struct type *expect_type, struct expression *exp,
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);
+ if (value_type (arg1)->code () == TYPE_CODE_COMPLEX
+ || value_type (arg2)->code () == TYPE_CODE_COMPLEX)
+ error (_("Types of arguments for CMPLX called with more then one argument "
+ "must be REAL or INTEGER"));
+
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_complex;
+ return value_literal_complex (arg1, arg2, result_type);
+}
+
+/* A helper function for FORTRAN_CMPLX. */
+
+value *
+eval_op_f_cmplx (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1, value *arg2, type *kind_arg)
+{
+ gdb_assert (kind_arg->code () == TYPE_CODE_COMPLEX);
+ if (value_type (arg1)->code () == TYPE_CODE_COMPLEX
+ || value_type (arg2)->code () == TYPE_CODE_COMPLEX)
+ error (_("Types of arguments for CMPLX called with more then one argument "
+ "must be REAL or INTEGER"));
+
+ return value_literal_complex (arg1, arg2, kind_arg);
}
/* A helper function for UNOP_FORTRAN_KIND. */
/* A helper function for UNOP_FORTRAN_ALLOCATED. */
-static struct value *
+struct value *
eval_op_f_allocated (struct type *expect_type, struct expression *exp,
enum noside noside, enum exp_opcode op,
struct value *arg1)
return value_from_longest (result_type, result_value);
}
-/* Special expression evaluation cases for Fortran. */
+/* See f-exp.h. */
-static struct value *
-evaluate_subexp_f (struct type *expect_type, struct expression *exp,
- int *pos, enum noside noside)
+struct value *
+eval_op_f_rank (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside,
+ enum exp_opcode op,
+ struct value *arg1)
{
- struct value *arg1 = NULL, *arg2 = NULL;
- enum exp_opcode op;
- int pc;
- struct type *type;
-
- pc = *pos;
- *pos += 1;
- op = exp->elts[pc].opcode;
+ gdb_assert (op == UNOP_FORTRAN_RANK);
- switch (op)
- {
- default:
- *pos -= 1;
- return evaluate_subexp_standard (expect_type, exp, pos, noside);
-
- case UNOP_ABS:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- 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, op, arg1, arg2);
-
- case UNOP_FORTRAN_CEILING:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- 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, op, arg1);
-
- case UNOP_FORTRAN_ALLOCATED:
- {
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- 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);
- return eval_op_f_modulo (expect_type, exp, noside, op, arg1, arg2);
-
- case FORTRAN_LBOUND:
- case FORTRAN_UBOUND:
- {
- int nargs = longest_to_int (exp->elts[pc + 1].longconst);
- (*pos) += 2;
-
- /* This assertion should be enforced by the expression parser. */
- gdb_assert (nargs == 1 || nargs == 2);
-
- bool lbound_p = op == FORTRAN_LBOUND;
-
- /* Check that the first argument is array like. */
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- fortran_require_array (value_type (arg1), lbound_p);
-
- if (nargs == 1)
- return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1);
-
- /* User asked for the bounds of a specific dimension of the array. */
- arg2 = evaluate_subexp (nullptr, exp, pos, noside);
- 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);
- }
- break;
-
- case FORTRAN_ASSOCIATED:
- {
- int nargs = longest_to_int (exp->elts[pc + 1].longconst);
- (*pos) += 2;
-
- /* This assertion should be enforced by the expression parser. */
- gdb_assert (nargs == 1 || nargs == 2);
-
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
-
- if (nargs == 1)
- {
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- return fortran_associated (exp->gdbarch, exp->language_defn,
- arg1);
- }
-
- arg2 = evaluate_subexp (nullptr, exp, pos, noside);
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- return fortran_associated (exp->gdbarch, exp->language_defn,
- arg1, arg2);
- }
- break;
+ struct type *result_type
+ = builtin_f_type (exp->gdbarch)->builtin_integer;
+ struct type *type = check_typedef (value_type (arg1));
+ if (type->code () != TYPE_CODE_ARRAY)
+ return value_from_longest (result_type, 0);
+ LONGEST ndim = calc_f77_array_dims (type);
+ return value_from_longest (result_type, ndim);
+}
- case BINOP_FORTRAN_CMPLX:
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
- 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);
- 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
- operations cannot be disambiguated at parse time. We have made
- all array subscript operations, substring operations as well as
- function calls come here and we now have to discover what the heck
- this thing actually was. If it is a function, we process just as
- if we got an OP_FUNCALL. */
- int nargs = longest_to_int (exp->elts[pc + 1].longconst);
- (*pos) += 2;
-
- /* First determine the type code we are dealing with. */
- arg1 = evaluate_subexp (nullptr, exp, pos, noside);
- type = check_typedef (value_type (arg1));
- 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)
- {
- arg1 = value_ind (arg1);
- type = check_typedef (value_type (arg1));
- code = type->code ();
- }
- }
+/* A helper function for UNOP_FORTRAN_LOC. */
- switch (code)
- {
- case TYPE_CODE_ARRAY:
- case TYPE_CODE_STRING:
- return fortran_value_subarray (arg1, exp, pos, nargs, 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. */
- struct value **argvec = (struct value **)
- alloca (sizeof (struct value *) * (nargs + 2));
- argvec[0] = arg1;
- int tem = 1;
- for (; tem <= nargs; tem++)
- {
- bool is_internal_func = (code == TYPE_CODE_INTERNAL_FUNCTION);
- argvec[tem]
- = fortran_prepare_argument (exp, pos, (tem - 1),
- is_internal_func,
- value_type (arg1), noside);
- }
- argvec[tem] = 0; /* signal end of arglist */
- if (noside == EVAL_SKIP)
- return eval_skip_value (exp);
- return evaluate_subexp_do_call (exp, noside, argvec[0],
- gdb::make_array_view (argvec + 1,
- nargs),
- NULL, expect_type);
- }
-
- default:
- error (_("Cannot perform substring on this type"));
- }
- }
+struct value *
+eval_op_f_loc (struct type *expect_type, struct expression *exp,
+ enum noside noside, enum exp_opcode op,
+ struct value *arg1)
+{
+ struct type *result_type;
+ if (gdbarch_ptr_bit (exp->gdbarch) == 16)
+ result_type = builtin_f_type (exp->gdbarch)->builtin_integer_s2;
+ else if (gdbarch_ptr_bit (exp->gdbarch) == 32)
+ result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ else
+ result_type = builtin_f_type (exp->gdbarch)->builtin_integer_s8;
- /* Should be unreachable. */
- return nullptr;
+ LONGEST result_value = value_address (arg1);
+ return value_from_longest (result_type, result_value);
}
namespace expr
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));
+ array = value_from_contents_and_address
+ (array_slice_type, value_contents (array).data () + total_offset,
+ value_address (array) + total_offset);
}
else if (!value_lazy (array))
array = value_from_component (array, array_slice_type, total_offset);
enum noside noside)
{
value *callee = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
+ if (noside == EVAL_AVOID_SIDE_EFFECTS
+ && is_dynamic_type (value_type (callee)))
+ callee = std::get<0> (m_storage)->evaluate (nullptr, exp, EVAL_NORMAL);
struct type *type = check_typedef (value_type (callee));
enum type_code code = type->code ();
/* 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)
+ type *type_arg2 = check_typedef (value_type (arg2));
+ if (type_arg2->code () != TYPE_CODE_INT)
{
if (lbound_p)
error (_("LBOUND second argument should be an integer"));
error (_("UBOUND second argument should be an integer"));
}
- return fortran_bounds_for_dimension (lbound_p, exp->gdbarch, arg1, arg2);
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_bounds_for_dimension (lbound_p, arg1, arg2, result_type);
}
-} /* namespace expr */
-
-/* Special expression lengths for Fortran. */
-
-static void
-operator_length_f (const struct expression *exp, int pc, int *oplenp,
- int *argsp)
+value *
+fortran_bound_3arg::evaluate (type *expect_type,
+ expression *exp,
+ noside noside)
{
- int oplen = 1;
- int args = 0;
+ const 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);
- switch (exp->elts[pc - 1].opcode)
+ /* User asked for the bounds of a specific dimension of the array. */
+ value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
+ type *type_arg2 = check_typedef (value_type (arg2));
+ if (type_arg2->code () != TYPE_CODE_INT)
{
- 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;
+ if (lbound_p)
+ error (_("LBOUND second argument should be an integer"));
+ else
+ error (_("UBOUND second argument should be an integer"));
}
- *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. */
+ type *kind_arg = std::get<3> (m_storage);
+ gdb_assert (kind_arg->code () == TYPE_CODE_INT);
-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);
+ return fortran_bounds_for_dimension (lbound_p, arg1, arg2, kind_arg);
}
-/* Special expression printing for Fortran. */
+/* Implement STRUCTOP_STRUCT for Fortran. See operation::evaluate in
+ expression.h for argument descriptions. */
-static void
-print_subexp_f (struct expression *exp, int *pos,
- struct ui_file *stream, enum precedence prec)
+value *
+fortran_structop_operation::evaluate (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside)
{
- int pc = *pos;
- enum exp_opcode op = exp->elts[pc].opcode;
-
- switch (op)
+ value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
+ const char *str = std::get<1> (m_storage).c_str ();
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
{
- default:
- print_subexp_standard (exp, pos, stream, prec);
- return;
-
- case UNOP_FORTRAN_KIND:
- print_unop_subexp_f (exp, pos, stream, prec, "KIND");
- return;
+ struct type *type = lookup_struct_elt_type (value_type (arg1), str, 1);
- case UNOP_FORTRAN_FLOOR:
- print_unop_subexp_f (exp, pos, stream, prec, "FLOOR");
- return;
-
- case UNOP_FORTRAN_CEILING:
- print_unop_subexp_f (exp, pos, stream, prec, "CEILING");
- return;
-
- case UNOP_FORTRAN_ALLOCATED:
- print_unop_subexp_f (exp, pos, stream, prec, "ALLOCATED");
- return;
-
- case BINOP_FORTRAN_CMPLX:
- print_binop_subexp_f (exp, pos, stream, prec, "CMPLX");
- return;
-
- case BINOP_FORTRAN_MODULO:
- print_binop_subexp_f (exp, pos, stream, prec, "MODULO");
- return;
-
- case FORTRAN_ASSOCIATED:
- print_unop_or_binop_subexp_f (exp, pos, stream, prec, "ASSOCIATED");
- return;
-
- case FORTRAN_LBOUND:
- print_unop_or_binop_subexp_f (exp, pos, stream, prec, "LBOUND");
- return;
-
- case FORTRAN_UBOUND:
- print_unop_or_binop_subexp_f (exp, pos, stream, prec, "UBOUND");
- return;
-
- case OP_F77_UNDETERMINED_ARGLIST:
- (*pos)++;
- print_subexp_funcall (exp, pos, stream);
- return;
+ if (type != nullptr && is_dynamic_type (type))
+ arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, EVAL_NORMAL);
}
-}
-
-/* Special expression dumping for Fortran. */
-static int
-dump_subexp_body_f (struct expression *exp,
- struct ui_file *stream, int elt)
-{
- int opcode = exp->elts[elt].opcode;
- int oplen, nargs, i;
+ value *elt = value_struct_elt (&arg1, {}, str, NULL, "structure");
- switch (opcode)
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
{
- default:
- return dump_subexp_body_standard (exp, stream, elt);
-
- case UNOP_FORTRAN_KIND:
- case UNOP_FORTRAN_FLOOR:
- case UNOP_FORTRAN_CEILING:
- case UNOP_FORTRAN_ALLOCATED:
- case BINOP_FORTRAN_CMPLX:
- case BINOP_FORTRAN_MODULO:
- operator_length_f (exp, (elt + 1), &oplen, &nargs);
- break;
-
- case FORTRAN_ASSOCIATED:
- case FORTRAN_LBOUND:
- case FORTRAN_UBOUND:
- operator_length_f (exp, (elt + 3), &oplen, &nargs);
- break;
-
- case OP_F77_UNDETERMINED_ARGLIST:
- return dump_subexp_body_funcall (exp, stream, elt + 1);
+ struct type *elt_type = value_type (elt);
+ if (is_dynamic_type (elt_type))
+ {
+ const gdb_byte *valaddr = value_contents_for_printing (elt).data ();
+ CORE_ADDR address = value_address (elt);
+ gdb::array_view<const gdb_byte> view
+ = gdb::make_array_view (valaddr, TYPE_LENGTH (elt_type));
+ elt_type = resolve_dynamic_type (elt_type, view, address);
+ }
+ elt = value_zero (elt_type, VALUE_LVAL (elt));
}
- elt += oplen;
- for (i = 0; i < nargs; i += 1)
- elt = dump_subexp (exp, stream, elt);
-
return elt;
}
-/* Special expression checking for Fortran. */
-
-static int
-operator_check_f (struct expression *exp, int pos,
- int (*objfile_func) (struct objfile *objfile,
- void *data),
- void *data)
-{
- const union exp_element *const elts = exp->elts;
+} /* namespace expr */
- switch (elts[pos].opcode)
- {
- case UNOP_FORTRAN_KIND:
- case UNOP_FORTRAN_FLOOR:
- case UNOP_FORTRAN_CEILING:
- case UNOP_FORTRAN_ALLOCATED:
- case BINOP_FORTRAN_CMPLX:
- case BINOP_FORTRAN_MODULO:
- case FORTRAN_ASSOCIATED:
- case FORTRAN_LBOUND:
- case FORTRAN_UBOUND:
- /* Any references to objfiles are held in the arguments to this
- expression, not within the expression itself, so no additional
- checking is required here, the outer expression iteration code
- will take care of checking each argument. */
- break;
+/* See language.h. */
- default:
- return operator_check_standard (exp, pos, objfile_func, data);
- }
+void
+f_language::print_array_index (struct type *index_type, LONGEST index,
+ struct ui_file *stream,
+ const value_print_options *options) const
+{
+ struct value *index_value = value_from_longest (index_type, index);
- return 0;
+ gdb_printf (stream, "(");
+ value_print (index_value, stream, options);
+ gdb_printf (stream, ") = ");
}
-/* Expression processing for Fortran. */
-const struct exp_descriptor f_language::exp_descriptor_tab =
-{
- print_subexp_f,
- operator_length_f,
- operator_check_f,
- dump_subexp_body_f,
- evaluate_subexp_f
-};
-
/* See language.h. */
void
add (builtin->builtin_real);
add (builtin->builtin_real_s8);
add (builtin->builtin_real_s16);
+ add (builtin->builtin_complex);
add (builtin->builtin_complex_s8);
- add (builtin->builtin_complex_s16);
add (builtin->builtin_void);
lai->set_string_char_type (builtin->builtin_character);
- lai->set_bool_type (builtin->builtin_logical_s2, "logical");
+ lai->set_bool_type (builtin->builtin_logical, "logical");
}
/* See language.h. */
builtin_f_type->builtin_logical_s1
= arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
- builtin_f_type->builtin_integer_s2
- = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
- "integer*2");
-
- builtin_f_type->builtin_integer_s8
- = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
- "integer*8");
-
builtin_f_type->builtin_logical_s2
- = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
- "logical*2");
+ = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1, "logical*2");
+
+ builtin_f_type->builtin_logical
+ = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "logical*4");
builtin_f_type->builtin_logical_s8
= arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
"logical*8");
+ builtin_f_type->builtin_integer_s1
+ = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "integer*1");
+
+ builtin_f_type->builtin_integer_s2
+ = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0, "integer*2");
+
builtin_f_type->builtin_integer
- = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
- "integer");
+ = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "integer*4");
- builtin_f_type->builtin_logical
- = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
- "logical*4");
+ builtin_f_type->builtin_integer_s8
+ = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
+ "integer*8");
builtin_f_type->builtin_real
= arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
- "real", gdbarch_float_format (gdbarch));
+ "real*4", gdbarch_float_format (gdbarch));
+
builtin_f_type->builtin_real_s8
= arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
"real*8", gdbarch_double_format (gdbarch));
+
auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
if (fmt != nullptr)
builtin_f_type->builtin_real_s16
builtin_f_type->builtin_real_s16
= arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
+ builtin_f_type->builtin_complex
+ = init_complex_type ("complex*4", builtin_f_type->builtin_real);
+
builtin_f_type->builtin_complex_s8
- = init_complex_type ("complex*8", builtin_f_type->builtin_real);
- builtin_f_type->builtin_complex_s16
- = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
+ = init_complex_type ("complex*8", builtin_f_type->builtin_real_s8);
if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
- builtin_f_type->builtin_complex_s32
- = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
+ builtin_f_type->builtin_complex_s16
+ = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*16");
else
- builtin_f_type->builtin_complex_s32
- = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
+ builtin_f_type->builtin_complex_s16
+ = init_complex_type ("complex*16", builtin_f_type->builtin_real_s16);
return builtin_f_type;
}
{
f_type_data = gdbarch_data_register_post_init (build_fortran_types);
- add_basic_prefix_cmd ("fortran", no_class,
- _("Prefix command for changing Fortran-specific settings."),
- &set_fortran_list, "set fortran ", 0, &setlist);
-
- add_show_prefix_cmd ("fortran", no_class,
- _("Generic command for showing Fortran-specific settings."),
- &show_fortran_list, "show fortran ", 0, &showlist);
+ add_setshow_prefix_cmd
+ ("fortran", no_class,
+ _("Prefix command for changing Fortran-specific settings."),
+ _("Generic command for showing Fortran-specific settings."),
+ &set_fortran_list, &show_fortran_list,
+ &setlist, &showlist);
add_setshow_boolean_cmd ("repack-array-slices", class_vars,
&repack_array_slices, _("\
const int length = TYPE_LENGTH (type);
const CORE_ADDR addr
= value_as_long (value_allocate_space_in_inferior (length));
- write_memory (addr, value_contents (value), length);
- struct value *val
- = value_from_contents_and_address (type, value_contents (value),
- addr);
+ write_memory (addr, value_contents (value).data (), length);
+ struct value *val = value_from_contents_and_address
+ (type, value_contents (value).data (), addr);
return value_addr (val);
}
else
return value;
}
-/* 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, int *pos,
- int arg_num, bool is_internal_call_p,
- struct type *func_type, enum noside noside)
-{
- if (is_internal_call_p)
- return evaluate_subexp_with_coercion (exp, pos, 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 && exp->elts[*pos].opcode == UNOP_ADDR)
- {
- (*pos)++;
- is_artificial = false;
- }
-
- struct value *arg_val = evaluate_subexp_with_coercion (exp, pos, noside);
- 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