/* Fortran language support routines for GDB, the GNU debugger.
- Copyright (C) 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003,
- 2004, 2005, 2007 Free Software Foundation, Inc.
+ Copyright (C) 1993-2021 Free Software Foundation, Inc.
Contributed by Motorola. Adapted from the C parser by Farooq Butt
(fmbutt@engage.sps.mot.com).
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
+ the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor,
- Boston, MA 02110-1301, USA. */
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
#include "defs.h"
-#include "gdb_string.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
+#include "varobj.h"
+#include "gdbcore.h"
#include "f-lang.h"
#include "valprint.h"
#include "value.h"
+#include "cp-support.h"
+#include "charset.h"
+#include "c-lang.h"
+#include "target-float.h"
+#include "gdbarch.h"
+#include "gdbcmd.h"
+#include "f-array-walker.h"
+#include "f-exp.h"
+#include <math.h>
-/* Following is dubious stuff that had been in the xcoff reader. */
-
-struct saved_fcn
- {
- long line_offset; /* Line offset for function */
- struct saved_fcn *next;
- };
+/* Whether GDB should repack array slices created by the user. */
+static bool repack_array_slices = false;
+/* Implement 'show fortran repack-array-slices'. */
+static void
+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);
+}
-struct saved_bf_symnum
- {
- long symnum_fcn; /* Symnum of function (i.e. .function directive) */
- long symnum_bf; /* Symnum of .bf for this function */
- struct saved_bf_symnum *next;
- };
+/* Debugging of Fortran's array slicing. */
+static bool fortran_array_slicing_debug = false;
-typedef struct saved_fcn SAVED_FUNCTION, *SAVED_FUNCTION_PTR;
-typedef struct saved_bf_symnum SAVED_BF, *SAVED_BF_PTR;
+/* Implement 'show debug fortran-array-slicing'. */
+static void
+show_fortran_array_slicing_debug (struct ui_file *file, int from_tty,
+ struct cmd_list_element *c,
+ const char *value)
+{
+ fprintf_filtered (file, _("Debugging of Fortran array slicing is %s.\n"),
+ value);
+}
/* Local functions */
-extern void _initialize_f_language (void);
-#if 0
-static void clear_function_list (void);
-static long get_bf_for_fcn (long);
-static void clear_bf_list (void);
-static void patch_all_commons_by_name (char *, CORE_ADDR, int);
-static SAVED_F77_COMMON_PTR find_first_common_named (char *);
-static void add_common_entry (struct symbol *);
-static void add_common_block (char *, CORE_ADDR, int, char *);
-static SAVED_FUNCTION *allocate_saved_function_node (void);
-static SAVED_BF_PTR allocate_saved_bf_node (void);
-static COMMON_ENTRY_PTR allocate_common_entry_node (void);
-static SAVED_F77_COMMON_PTR allocate_saved_f77_common_node (void);
-static void patch_common_entries (SAVED_F77_COMMON_PTR, CORE_ADDR, int);
-#endif
-
-static struct type *f_create_fundamental_type (struct objfile *, int);
-static void f_printchar (int c, struct ui_file * stream);
-static void f_emit_char (int c, struct ui_file * stream, int quoter);
-
-/* Print the character C on STREAM as part of the contents of a literal
- string whose delimiter is QUOTER. Note that that format for printing
- characters and strings is language specific.
- FIXME: This is a copy of the same function from c-exp.y. It should
- be replaced with a true F77 version. */
+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);
-static void
-f_emit_char (int c, struct ui_file *stream, int quoter)
+/* Return the encoding that should be used for the character type
+ TYPE. */
+
+const char *
+f_language::get_encoding (struct type *type)
{
- c &= 0xFF; /* Avoid sign bit follies */
+ const char *encoding;
- if (PRINT_LITERAL_FORM (c))
- {
- if (c == '\\' || c == quoter)
- fputs_filtered ("\\", stream);
- fprintf_filtered (stream, "%c", c);
- }
- else
+ switch (TYPE_LENGTH (type))
{
- switch (c)
- {
- case '\n':
- fputs_filtered ("\\n", stream);
- break;
- case '\b':
- fputs_filtered ("\\b", stream);
- break;
- case '\t':
- fputs_filtered ("\\t", stream);
- break;
- case '\f':
- fputs_filtered ("\\f", stream);
- break;
- case '\r':
- fputs_filtered ("\\r", stream);
- break;
- case '\033':
- fputs_filtered ("\\e", stream);
- break;
- case '\007':
- fputs_filtered ("\\a", stream);
- break;
- default:
- fprintf_filtered (stream, "\\%.3o", (unsigned int) c);
- break;
- }
+ case 1:
+ encoding = target_charset (type->arch ());
+ break;
+ case 4:
+ if (type_byte_order (type) == BFD_ENDIAN_BIG)
+ encoding = "UTF-32BE";
+ else
+ encoding = "UTF-32LE";
+ break;
+
+ default:
+ error (_("unrecognized character type"));
}
+
+ return encoding;
}
-/* FIXME: This is a copy of the same function from c-exp.y. It should
- be replaced with a true F77version. */
+\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
-f_printchar (int c, struct ui_file *stream)
+fortran_require_array (struct type *type, bool lbound_p)
{
- fputs_filtered ("'", stream);
- LA_EMIT_CHAR (c, stream, '\'');
- fputs_filtered ("'", stream);
+ 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"));
+ }
}
-/* Print the character string STRING, printing at most LENGTH characters.
- Printing stops early if the number hits print_max; repeat counts
- are printed as appropriate. Print ellipses at the end if we
- had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
- FIXME: This is a copy of the same function from c-exp.y. It should
- be replaced with a true F77 version. */
+/* 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. */
-static void
-f_printstr (struct ui_file *stream, const gdb_byte *string,
- unsigned int length, int width, int force_ellipses)
+static struct value *
+fortran_bounds_all_dims (bool lbound_p,
+ struct gdbarch *gdbarch,
+ struct value *array)
{
- unsigned int i;
- unsigned int things_printed = 0;
- int in_quotes = 0;
- int need_comma = 0;
-
- if (length == 0)
+ type *array_type = check_typedef (value_type (array));
+ int ndimensions = calc_f77_array_dims (array_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_type (gdbarch)->builtin_long_long;
+ struct type *result_type = create_array_type (nullptr, elm_type, range);
+ struct value *result = allocate_value (result_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. */
+ LONGEST elm_len = TYPE_LENGTH (elm_type);
+ for (LONGEST dst_offset = elm_len * (ndimensions - 1);
+ dst_offset >= 0;
+ dst_offset -= elm_len)
{
- fputs_filtered ("''", gdb_stdout);
- return;
+ LONGEST b;
+
+ /* Grab the required bound. */
+ if (lbound_p)
+ b = f77_get_lowerbound (array_type);
+ else
+ b = f77_get_upperbound (array_type);
+
+ /* And copy the value into the result value. */
+ struct value *v = value_from_longest (elm_type, b);
+ 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. */
+ array_type = TYPE_TARGET_TYPE (array_type);
}
- for (i = 0; i < length && things_printed < print_max; ++i)
+ return result;
+}
+
+/* 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. */
+
+static struct value *
+fortran_bounds_for_dimension (bool lbound_p,
+ struct gdbarch *gdbarch,
+ struct value *array,
+ struct value *dim_val)
+{
+ /* Check the requested dimension is valid for this array. */
+ type *array_type = check_typedef (value_type (array));
+ int ndimensions = calc_f77_array_dims (array_type);
+ long dim = value_as_long (dim_val);
+ if (dim < 1 || dim > ndimensions)
{
- /* Position of the character we are examining
- to see whether it is repeated. */
- unsigned int rep1;
- /* Number of repetitions we have detected so far. */
- unsigned int reps;
+ if (lbound_p)
+ error (_("LBOUND dimension must be from 1 to %d"), ndimensions);
+ else
+ error (_("UBOUND dimension must be from 1 to %d"), ndimensions);
+ }
- QUIT;
+ /* The type for the result. */
+ struct type *bound_type = builtin_type (gdbarch)->builtin_long_long;
- if (need_comma)
+ /* 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)
+ {
+ /* If this is the requested dimension then we're done. Grab the
+ bounds and return. */
+ if (i == dim - 1)
{
- fputs_filtered (", ", stream);
- need_comma = 0;
- }
+ LONGEST b;
- rep1 = i + 1;
- reps = 1;
- while (rep1 < length && string[rep1] == string[i])
- {
- ++rep1;
- ++reps;
- }
+ if (lbound_p)
+ b = f77_get_lowerbound (array_type);
+ else
+ b = f77_get_upperbound (array_type);
- if (reps > repeat_count_threshold)
- {
- if (in_quotes)
- {
- if (inspect_it)
- fputs_filtered ("\\', ", stream);
- else
- fputs_filtered ("', ", stream);
- in_quotes = 0;
- }
- f_printchar (string[i], stream);
- fprintf_filtered (stream, " <repeats %u times>", reps);
- i = rep1 - 1;
- things_printed += repeat_count_threshold;
- need_comma = 1;
+ return value_from_longest (bound_type, b);
}
- else
- {
- if (!in_quotes)
- {
- if (inspect_it)
- fputs_filtered ("\\'", stream);
- else
- fputs_filtered ("'", stream);
- in_quotes = 1;
- }
- LA_EMIT_CHAR (string[i], stream, '"');
- ++things_printed;
- }
- }
- /* Terminate the quotes if necessary. */
- if (in_quotes)
- {
- if (inspect_it)
- fputs_filtered ("\\'", stream);
- else
- fputs_filtered ("'", stream);
+ /* Peel off another dimension of the array. */
+ array_type = TYPE_TARGET_TYPE (array_type);
}
- if (force_ellipses || i < length)
- fputs_filtered ("...", stream);
+ gdb_assert_not_reached ("failed to find matching dimension");
}
+\f
-/* FIXME: This is a copy of c_create_fundamental_type(), before
- all the non-C types were stripped from it. Needs to be fixed
- by an experienced F77 programmer. */
+/* Return the number of dimensions for a Fortran array or string. */
-static struct type *
-f_create_fundamental_type (struct objfile *objfile, int typeid)
+int
+calc_f77_array_dims (struct type *array_type)
{
- struct type *type = NULL;
+ int ndimen = 1;
+ struct type *tmp_type;
+
+ if ((array_type->code () == TYPE_CODE_STRING))
+ return 1;
- switch (typeid)
+ if ((array_type->code () != TYPE_CODE_ARRAY))
+ error (_("Can't get dimensions for a non-array type"));
+
+ tmp_type = array_type;
+
+ while ((tmp_type = TYPE_TARGET_TYPE (tmp_type)))
{
- case FT_VOID:
- type = init_type (TYPE_CODE_VOID,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "VOID", objfile);
- break;
- case FT_BOOLEAN:
- type = init_type (TYPE_CODE_BOOL,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "boolean", objfile);
- break;
- case FT_STRING:
- type = init_type (TYPE_CODE_STRING,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "string", objfile);
- break;
- case FT_CHAR:
- type = init_type (TYPE_CODE_INT,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "character", objfile);
- break;
- case FT_SIGNED_CHAR:
- type = init_type (TYPE_CODE_INT,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "integer*1", objfile);
- break;
- case FT_UNSIGNED_CHAR:
- type = init_type (TYPE_CODE_BOOL,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "logical*1", objfile);
- break;
- case FT_SHORT:
- type = init_type (TYPE_CODE_INT,
- gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "integer*2", objfile);
- break;
- case FT_SIGNED_SHORT:
- type = init_type (TYPE_CODE_INT,
- gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "short", objfile); /* FIXME-fnf */
- break;
- case FT_UNSIGNED_SHORT:
- type = init_type (TYPE_CODE_BOOL,
- gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "logical*2", objfile);
- break;
- case FT_INTEGER:
- type = init_type (TYPE_CODE_INT,
- gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "integer*4", objfile);
- break;
- case FT_SIGNED_INTEGER:
- type = init_type (TYPE_CODE_INT,
- gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "integer", objfile); /* FIXME -fnf */
- break;
- case FT_UNSIGNED_INTEGER:
- type = init_type (TYPE_CODE_BOOL,
- gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "logical*4", objfile);
- break;
- case FT_FIXED_DECIMAL:
- type = init_type (TYPE_CODE_INT,
- gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "fixed decimal", objfile);
- break;
- case FT_LONG:
- type = init_type (TYPE_CODE_INT,
- gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "long", objfile);
- break;
- case FT_SIGNED_LONG:
- type = init_type (TYPE_CODE_INT,
- gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "long", objfile); /* FIXME -fnf */
- break;
- case FT_UNSIGNED_LONG:
- type = init_type (TYPE_CODE_INT,
- gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
- break;
- case FT_LONG_LONG:
- type = init_type (TYPE_CODE_INT,
- gdbarch_long_long_bit (current_gdbarch)
- / TARGET_CHAR_BIT,
- 0, "long long", objfile);
- break;
- case FT_SIGNED_LONG_LONG:
- type = init_type (TYPE_CODE_INT,
- gdbarch_long_long_bit (current_gdbarch)
- / TARGET_CHAR_BIT,
- 0, "signed long long", objfile);
- break;
- case FT_UNSIGNED_LONG_LONG:
- type = init_type (TYPE_CODE_INT,
- gdbarch_long_long_bit (current_gdbarch)
- / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
- break;
- case FT_FLOAT:
- type = init_type (TYPE_CODE_FLT,
- gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "real", objfile);
- break;
- case FT_DBL_PREC_FLOAT:
- type = init_type (TYPE_CODE_FLT,
- gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "real*8", objfile);
- break;
- case FT_FLOAT_DECIMAL:
- type = init_type (TYPE_CODE_FLT,
- gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "floating decimal", objfile);
- break;
- case FT_EXT_PREC_FLOAT:
- type = init_type (TYPE_CODE_FLT,
- gdbarch_long_double_bit (current_gdbarch)
- / TARGET_CHAR_BIT,
- 0, "real*16", objfile);
- break;
- case FT_COMPLEX:
- type = init_type (TYPE_CODE_COMPLEX,
- 2 * gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "complex*8", objfile);
- TYPE_TARGET_TYPE (type) = builtin_type_f_real;
- break;
- case FT_DBL_PREC_COMPLEX:
- type = init_type (TYPE_CODE_COMPLEX,
- 2 * gdbarch_double_bit (current_gdbarch)
- / TARGET_CHAR_BIT,
- 0, "complex*16", objfile);
- TYPE_TARGET_TYPE (type) = builtin_type_f_real_s8;
- break;
- case FT_EXT_PREC_COMPLEX:
- type = init_type (TYPE_CODE_COMPLEX,
- 2 * gdbarch_long_double_bit (current_gdbarch)
- / TARGET_CHAR_BIT,
- 0, "complex*32", objfile);
- TYPE_TARGET_TYPE (type) = builtin_type_f_real_s16;
- break;
- default:
- /* FIXME: For now, if we are asked to produce a type not in this
- language, create the equivalent of a C integer type with the
- name "<?type?>". When all the dust settles from the type
- reconstruction work, this should probably become an error. */
- type = init_type (TYPE_CODE_INT,
- gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "<?type?>", objfile);
- warning (_("internal error: no F77 fundamental type %d"), typeid);
- break;
+ if (tmp_type->code () == TYPE_CODE_ARRAY)
+ ++ndimen;
}
- return (type);
+ return ndimen;
}
-\f
-/* Table of operators and their precedences for printing expressions. */
-
-static const struct op_print f_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, 0, 0, 0}
+/* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
+ slices. This is a base class for two alternative repacking mechanisms,
+ one for when repacking from a lazy value, and one for repacking from a
+ non-lazy (already loaded) value. */
+class fortran_array_repacker_base_impl
+ : public fortran_array_walker_base_impl
+{
+public:
+ /* Constructor, DEST is the value we are repacking into. */
+ fortran_array_repacker_base_impl (struct value *dest)
+ : m_dest (dest),
+ m_dest_offset (0)
+ { /* Nothing. */ }
+
+ /* When we start processing the inner most dimension, this is where we
+ 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)
+ {
+ if (inner_p)
+ {
+ gdb_assert (m_mark == nullptr);
+ m_mark = value_mark ();
+ }
+ }
+
+ /* When we finish processing the inner most dimension free all temporary
+ value that were created. */
+ void finish_dimension (bool inner_p, bool last_p)
+ {
+ if (inner_p)
+ {
+ gdb_assert (m_mark != nullptr);
+ value_free_to_mark (m_mark);
+ m_mark = nullptr;
+ }
+ }
+
+protected:
+ /* Copy the contents of array element ELT into M_DEST at the next
+ available offset. */
+ void copy_element_to_dest (struct value *elt)
+ {
+ value_contents_copy (m_dest, m_dest_offset, elt, 0,
+ TYPE_LENGTH (value_type (elt)));
+ m_dest_offset += TYPE_LENGTH (value_type (elt));
+ }
+
+ /* The value being written to. */
+ struct value *m_dest;
+
+ /* The byte offset in M_DEST at which the next element should be
+ written. */
+ LONGEST m_dest_offset;
+
+ /* Set with a call to VALUE_MARK, and then reset after calling
+ VALUE_FREE_TO_MARK. */
+ struct value *m_mark = nullptr;
};
-\f
-enum f_primitive_types {
- f_primitive_type_character,
- f_primitive_type_logical,
- f_primitive_type_logical_s1,
- f_primitive_type_logical_s2,
- f_primitive_type_integer,
- f_primitive_type_integer_s2,
- f_primitive_type_real,
- f_primitive_type_real_s8,
- f_primitive_type_real_s16,
- f_primitive_type_complex_s8,
- f_primitive_type_complex_s16,
- f_primitive_type_void,
- nr_f_primitive_types
+
+/* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
+ slices. This class is specialised for repacking an array slice from a
+ lazy array value, as such it does not require the parent array value to
+ be loaded into GDB's memory; the parent value could be huge, while the
+ slice could be tiny. */
+class fortran_lazy_array_repacker_impl
+ : public fortran_array_repacker_base_impl
+{
+public:
+ /* Constructor. TYPE is the type of the slice being loaded from the
+ parent value, so this type will correctly reflect the strides required
+ to find all of the elements from the parent value. ADDRESS is the
+ address in target memory of value matching TYPE, and DEST is the value
+ we are repacking into. */
+ explicit fortran_lazy_array_repacker_impl (struct type *type,
+ CORE_ADDR address,
+ struct value *dest)
+ : fortran_array_repacker_base_impl (dest),
+ m_addr (address)
+ { /* Nothing. */ }
+
+ /* 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)
+ {
+ copy_element_to_dest (value_at_lazy (elt_type, m_addr + elt_off));
+ }
+
+private:
+ /* The address in target memory where the parent value starts. */
+ CORE_ADDR m_addr;
};
-static void
-f_language_arch_info (struct gdbarch *gdbarch,
- struct language_arch_info *lai)
+/* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
+ slices. This class is specialised for repacking an array slice from a
+ previously loaded (non-lazy) array value, as such it fetches the
+ element values from the contents of the parent value. */
+class fortran_array_repacker_impl
+ : public fortran_array_repacker_base_impl
{
- const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
+public:
+ /* Constructor. TYPE is the type for the array slice within the parent
+ value, as such it has stride values as required to find the elements
+ within the original parent value. ADDRESS is the address in target
+ memory of the value matching TYPE. BASE_OFFSET is the offset from
+ the start of VAL's content buffer to the start of the object of TYPE,
+ VAL is the parent object from which we are loading the value, and
+ DEST is the value into which we are repacking. */
+ explicit fortran_array_repacker_impl (struct type *type, CORE_ADDR address,
+ LONGEST base_offset,
+ struct value *val, struct value *dest)
+ : fortran_array_repacker_base_impl (dest),
+ m_base_offset (base_offset),
+ m_val (val)
+ {
+ gdb_assert (!value_lazy (val));
+ }
- lai->string_char_type = builtin->builtin_character;
- lai->primitive_type_vector
- = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
- struct type *);
-
- lai->primitive_type_vector [f_primitive_type_character]
- = builtin->builtin_character;
- lai->primitive_type_vector [f_primitive_type_logical]
- = builtin->builtin_logical;
- lai->primitive_type_vector [f_primitive_type_logical_s1]
- = builtin->builtin_logical_s1;
- lai->primitive_type_vector [f_primitive_type_logical_s2]
- = builtin->builtin_logical_s2;
- lai->primitive_type_vector [f_primitive_type_real]
- = builtin->builtin_real;
- lai->primitive_type_vector [f_primitive_type_real_s8]
- = builtin->builtin_real_s8;
- lai->primitive_type_vector [f_primitive_type_real_s16]
- = builtin->builtin_real_s16;
- lai->primitive_type_vector [f_primitive_type_complex_s8]
- = builtin->builtin_complex_s8;
- lai->primitive_type_vector [f_primitive_type_complex_s16]
- = builtin->builtin_complex_s16;
- lai->primitive_type_vector [f_primitive_type_void]
- = builtin->builtin_void;
-}
-
-/* This is declared in c-lang.h but it is silly to import that file for what
- is already just a hack. */
-extern int c_value_print (struct value *, struct ui_file *, int,
- enum val_prettyprint);
-
-const struct language_defn f_language_defn =
-{
- "fortran",
- language_fortran,
- NULL,
- range_check_on,
- type_check_on,
- case_sensitive_off,
- array_column_major,
- &exp_descriptor_standard,
- f_parse, /* parser */
- f_error, /* parser error function */
- null_post_parser,
- f_printchar, /* Print character constant */
- f_printstr, /* function to print string constant */
- f_emit_char, /* Function to print a single character */
- f_create_fundamental_type, /* Create fundamental type in this language */
- f_print_type, /* Print a type using appropriate syntax */
- f_val_print, /* Print a value using appropriate syntax */
- c_value_print, /* FIXME */
- NULL, /* Language specific skip_trampoline */
- value_of_this, /* value_of_this */
- basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
- basic_lookup_transparent_type,/* lookup_transparent_type */
- NULL, /* Language specific symbol demangler */
- NULL, /* Language specific class_name_from_physname */
- f_op_print_tab, /* expression operators for printing */
- 0, /* arrays are first-class (not c-style) */
- 1, /* String lower bound */
- NULL,
- default_word_break_characters,
- f_language_arch_info,
- default_print_array_index,
- LANG_MAGIC
+ /* 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)
+ {
+ struct value *elt
+ = value_from_component (m_val, elt_type, (elt_off + m_base_offset));
+ copy_element_to_dest (elt);
+ }
+
+private:
+ /* The offset into the content buffer of M_VAL to the start of the slice
+ being extracted. */
+ LONGEST m_base_offset;
+
+ /* The parent value from which we are extracting a slice. */
+ struct value *m_val;
};
-static void *
-build_fortran_types (struct gdbarch *gdbarch)
+
+/* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
+ extracted from the expression being evaluated. POINTER is the required
+ first argument to the 'associated' keyword, and TARGET is the optional
+ second argument, this will be nullptr if the user only passed one
+ argument to their use of 'associated'. */
+
+static struct value *
+fortran_associated (struct gdbarch *gdbarch, const language_defn *lang,
+ struct value *pointer, struct value *target = nullptr)
{
- struct builtin_f_type *builtin_f_type
- = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
+ struct type *result_type = language_bool_type (lang, gdbarch);
+
+ /* All Fortran pointers should have the associated property, this is
+ how we know the pointer is pointing at something or not. */
+ struct type *pointer_type = check_typedef (value_type (pointer));
+ if (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr
+ && pointer_type->code () != TYPE_CODE_PTR)
+ error (_("ASSOCIATED can only be applied to pointers"));
+
+ /* Get an address from POINTER. Fortran (or at least gfortran) models
+ array pointers as arrays with a dynamic data address, so we need to
+ use two approaches here, for real pointers we take the contents of the
+ pointer as an address. For non-pointers we take the address of the
+ content. */
+ CORE_ADDR pointer_addr;
+ if (pointer_type->code () == TYPE_CODE_PTR)
+ pointer_addr = value_as_address (pointer);
+ else
+ pointer_addr = value_address (pointer);
- builtin_f_type->builtin_void =
- init_type (TYPE_CODE_VOID, 1,
- 0,
- "VOID", (struct objfile *) NULL);
-
- builtin_f_type->builtin_character =
- init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0,
- "character", (struct objfile *) NULL);
-
- builtin_f_type->builtin_logical_s1 =
- init_type (TYPE_CODE_BOOL, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED,
- "logical*1", (struct objfile *) NULL);
-
- builtin_f_type->builtin_integer_s2 =
- init_type (TYPE_CODE_INT,
- gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "integer*2", (struct objfile *) NULL);
-
- builtin_f_type->builtin_logical_s2 =
- init_type (TYPE_CODE_BOOL,
- gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "logical*2", (struct objfile *) NULL);
-
- builtin_f_type->builtin_integer =
- init_type (TYPE_CODE_INT,
- gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0, "integer", (struct objfile *) NULL);
-
- builtin_f_type->builtin_logical =
- init_type (TYPE_CODE_BOOL,
- gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "logical*4", (struct objfile *) NULL);
-
- builtin_f_type->builtin_real =
- init_type (TYPE_CODE_FLT,
- gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0,
- "real", (struct objfile *) NULL);
-
- builtin_f_type->builtin_real_s8 =
- init_type (TYPE_CODE_FLT,
- gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0,
- "real*8", (struct objfile *) NULL);
-
- builtin_f_type->builtin_real_s16 =
- init_type (TYPE_CODE_FLT,
- gdbarch_long_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0,
- "real*16", (struct objfile *) NULL);
-
- builtin_f_type->builtin_complex_s8 =
- init_type (TYPE_CODE_COMPLEX,
- 2 * gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0,
- "complex*8", (struct objfile *) NULL);
- TYPE_TARGET_TYPE (builtin_f_type->builtin_complex_s8)
- = builtin_f_type->builtin_real;
-
- builtin_f_type->builtin_complex_s16 =
- init_type (TYPE_CODE_COMPLEX,
- 2 * gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0,
- "complex*16", (struct objfile *) NULL);
- TYPE_TARGET_TYPE (builtin_f_type->builtin_complex_s16)
- = builtin_f_type->builtin_real_s8;
-
- /* We have a new size == 4 double floats for the
- complex*32 data type */
-
- builtin_f_type->builtin_complex_s32 =
- init_type (TYPE_CODE_COMPLEX,
- 2 * gdbarch_long_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
- 0,
- "complex*32", (struct objfile *) NULL);
- TYPE_TARGET_TYPE (builtin_f_type->builtin_complex_s32)
- = builtin_f_type->builtin_real_s16;
+ /* The single argument case, is POINTER associated with anything? */
+ if (target == nullptr)
+ {
+ bool is_associated = false;
+
+ /* If POINTER is an actual pointer and doesn't have an associated
+ property then we need to figure out whether this pointer is
+ associated by looking at the value of the pointer itself. We make
+ the assumption that a non-associated pointer will be set to 0.
+ This is probably true for most targets, but might not be true for
+ everyone. */
+ if (pointer_type->code () == TYPE_CODE_PTR
+ && TYPE_ASSOCIATED_PROP (pointer_type) == nullptr)
+ is_associated = (pointer_addr != 0);
+ else
+ is_associated = !type_not_associated (pointer_type);
+ return value_from_longest (result_type, is_associated ? 1 : 0);
+ }
- return builtin_f_type;
+ /* The two argument case, is POINTER associated with TARGET? */
+
+ struct type *target_type = check_typedef (value_type (target));
+
+ struct type *pointer_target_type;
+ if (pointer_type->code () == TYPE_CODE_PTR)
+ pointer_target_type = TYPE_TARGET_TYPE (pointer_type);
+ else
+ pointer_target_type = pointer_type;
+
+ struct type *target_target_type;
+ if (target_type->code () == TYPE_CODE_PTR)
+ target_target_type = TYPE_TARGET_TYPE (target_type);
+ else
+ target_target_type = target_type;
+
+ if (pointer_target_type->code () != target_target_type->code ()
+ || (pointer_target_type->code () != TYPE_CODE_ARRAY
+ && (TYPE_LENGTH (pointer_target_type)
+ != TYPE_LENGTH (target_target_type))))
+ error (_("arguments to associated must be of same type and kind"));
+
+ /* If TARGET is not in memory, or the original pointer is specifically
+ known to be not associated with anything, then the answer is obviously
+ false. Alternatively, if POINTER is an actual pointer and has no
+ associated property, then we have to check if its associated by
+ looking the value of the pointer itself. We make the assumption that
+ a non-associated pointer will be set to 0. This is probably true for
+ most targets, but might not be true for everyone. */
+ if (value_lval_const (target) != lval_memory
+ || type_not_associated (pointer_type)
+ || (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr
+ && pointer_type->code () == TYPE_CODE_PTR
+ && pointer_addr == 0))
+ return value_from_longest (result_type, 0);
+
+ /* See the comment for POINTER_ADDR above. */
+ CORE_ADDR target_addr;
+ if (target_type->code () == TYPE_CODE_PTR)
+ target_addr = value_as_address (target);
+ else
+ target_addr = value_address (target);
+
+ /* Wrap the following checks inside a do { ... } while (false) loop so
+ that we can use `break' to jump out of the loop. */
+ bool is_associated = false;
+ do
+ {
+ /* If the addresses are different then POINTER is definitely not
+ pointing at TARGET. */
+ if (pointer_addr != target_addr)
+ break;
+
+ /* If POINTER is a real pointer (i.e. not an array pointer, which are
+ implemented as arrays with a dynamic content address), then this
+ is all the checking that is needed. */
+ if (pointer_type->code () == TYPE_CODE_PTR)
+ {
+ is_associated = true;
+ break;
+ }
+
+ /* We have an array pointer. Check the number of dimensions. */
+ int pointer_dims = calc_f77_array_dims (pointer_type);
+ int target_dims = calc_f77_array_dims (target_type);
+ if (pointer_dims != target_dims)
+ break;
+
+ /* Now check that every dimension has the same upper bound, lower
+ bound, and stride value. */
+ int dim = 0;
+ while (dim < pointer_dims)
+ {
+ LONGEST pointer_lowerbound, pointer_upperbound, pointer_stride;
+ LONGEST target_lowerbound, target_upperbound, target_stride;
+
+ pointer_type = check_typedef (pointer_type);
+ target_type = check_typedef (target_type);
+
+ struct type *pointer_range = pointer_type->index_type ();
+ struct type *target_range = target_type->index_type ();
+
+ if (!get_discrete_bounds (pointer_range, &pointer_lowerbound,
+ &pointer_upperbound))
+ break;
+
+ if (!get_discrete_bounds (target_range, &target_lowerbound,
+ &target_upperbound))
+ break;
+
+ if (pointer_lowerbound != target_lowerbound
+ || pointer_upperbound != target_upperbound)
+ break;
+
+ /* Figure out the stride (in bits) for both pointer and target.
+ If either doesn't have a stride then we take the element size,
+ but we need to convert to bits (hence the * 8). */
+ pointer_stride = pointer_range->bounds ()->bit_stride ();
+ if (pointer_stride == 0)
+ pointer_stride
+ = type_length_units (check_typedef
+ (TYPE_TARGET_TYPE (pointer_type))) * 8;
+ target_stride = target_range->bounds ()->bit_stride ();
+ if (target_stride == 0)
+ target_stride
+ = type_length_units (check_typedef
+ (TYPE_TARGET_TYPE (target_type))) * 8;
+ if (pointer_stride != target_stride)
+ break;
+
+ ++dim;
+ }
+
+ if (dim < pointer_dims)
+ break;
+
+ is_associated = true;
+ }
+ while (false);
+
+ return value_from_longest (result_type, is_associated ? 1 : 0);
}
-static struct gdbarch_data *f_type_data;
+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);
+}
-const struct builtin_f_type *
-builtin_f_type (struct gdbarch *gdbarch)
+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 gdbarch_data (gdbarch, f_type_data);
+ return fortran_associated (exp->gdbarch, exp->language_defn, arg1, arg2);
}
-void
-_initialize_f_language (void)
+/* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE'
+ keyword. Both GDBARCH and LANG are extracted from the expression being
+ evaluated. 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 struct value *
+fortran_array_size (struct gdbarch *gdbarch, const language_defn *lang,
+ struct value *array, struct value *dim_val = nullptr)
{
- f_type_data = gdbarch_data_register_post_init (build_fortran_types);
+ /* 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);
+ }
- add_language (&f_language_defn);
+ struct type *result_type
+ = builtin_f_type (gdbarch)->builtin_integer;
+ return value_from_longest (result_type, result);
}
-#if 0
-static SAVED_BF_PTR
-allocate_saved_bf_node (void)
+/* 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)
{
- SAVED_BF_PTR new;
+ gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
+ return fortran_array_size (exp->gdbarch, exp->language_defn, arg1);
+}
+
+/* See f-exp.h. */
- new = (SAVED_BF_PTR) xmalloc (sizeof (SAVED_BF));
- return (new);
+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);
+ return fortran_array_size (exp->gdbarch, exp->language_defn, arg1, arg2);
}
-static SAVED_FUNCTION *
-allocate_saved_function_node (void)
+/* 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)
{
- SAVED_FUNCTION *new;
+ 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"));
- new = (SAVED_FUNCTION *) xmalloc (sizeof (SAVED_FUNCTION));
- return (new);
+ 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);
+ }
+
+ return result;
}
-static SAVED_F77_COMMON_PTR
-allocate_saved_f77_common_node (void)
+/* See f-exp.h. */
+
+struct value *
+eval_op_f_array_shape (struct type *expect_type, struct expression *exp,
+ enum noside noside, enum exp_opcode opcode,
+ struct value *arg1)
{
- SAVED_F77_COMMON_PTR new;
+ gdb_assert (opcode == UNOP_FORTRAN_SHAPE);
+ return fortran_array_shape (exp->gdbarch, exp->language_defn, arg1);
+}
- new = (SAVED_F77_COMMON_PTR) xmalloc (sizeof (SAVED_F77_COMMON));
- return (new);
+/* A helper function for UNOP_ABS. */
+
+struct value *
+eval_op_f_abs (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_FLT:
+ {
+ double d
+ = fabs (target_float_to_host_double (value_contents (arg1),
+ value_type (arg1)));
+ return value_from_host_double (type, d);
+ }
+ case TYPE_CODE_INT:
+ {
+ LONGEST l = value_as_long (arg1);
+ l = llabs (l);
+ return value_from_longest (type, l);
+ }
+ }
+ error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
}
-static COMMON_ENTRY_PTR
-allocate_common_entry_node (void)
+/* A helper function for BINOP_MOD. */
+
+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)
{
- COMMON_ENTRY_PTR new;
+ struct type *type = value_type (arg1);
+ if (type->code () != value_type (arg2)->code ())
+ error (_("non-matching types for parameters to MOD ()"));
+ switch (type->code ())
+ {
+ case TYPE_CODE_FLT:
+ {
+ double d1
+ = target_float_to_host_double (value_contents (arg1),
+ value_type (arg1));
+ double d2
+ = target_float_to_host_double (value_contents (arg2),
+ value_type (arg2));
+ double d3 = fmod (d1, d2);
+ return value_from_host_double (type, d3);
+ }
+ case TYPE_CODE_INT:
+ {
+ LONGEST v1 = value_as_long (arg1);
+ LONGEST v2 = value_as_long (arg2);
+ if (v2 == 0)
+ error (_("calling MOD (N, 0) is undefined"));
+ LONGEST v3 = v1 - (v1 / v2) * v2;
+ return value_from_longest (value_type (arg1), v3);
+ }
+ }
+ error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
+}
+
+/* A helper function for UNOP_FORTRAN_CEILING. */
- new = (COMMON_ENTRY_PTR) xmalloc (sizeof (COMMON_ENTRY));
- return (new);
+struct value *
+eval_op_f_ceil (struct type *expect_type, struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1)
+{
+ 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);
}
-#endif
-SAVED_F77_COMMON_PTR head_common_list = NULL; /* Ptr to 1st saved COMMON */
-SAVED_F77_COMMON_PTR tail_common_list = NULL; /* Ptr to last saved COMMON */
-SAVED_F77_COMMON_PTR current_common = NULL; /* Ptr to current COMMON */
+/* A helper function for UNOP_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)
+{
+ struct type *type = value_type (arg1);
+ if (type->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));
+ val = floor (val);
+ return value_from_host_double (type, val);
+}
-#if 0
-static SAVED_BF_PTR saved_bf_list = NULL; /* Ptr to (.bf,function)
- list */
-static SAVED_BF_PTR saved_bf_list_end = NULL; /* Ptr to above list's end */
-static SAVED_BF_PTR current_head_bf_list = NULL; /* Current head of above list
- */
+/* A helper function for BINOP_FORTRAN_MODULO. */
-static SAVED_BF_PTR tmp_bf_ptr; /* Generic temporary for use
- in macros */
+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)
+{
+ 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));
+}
-/* The following function simply enters a given common block onto
- the global common block chain */
+/* A helper function for BINOP_FORTRAN_CMPLX. */
-static void
-add_common_block (char *name, CORE_ADDR offset, int secnum, char *func_stab)
+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)
{
- SAVED_F77_COMMON_PTR tmp;
- char *c, *local_copy_func_stab;
+ struct type *type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
+ return value_literal_complex (arg1, arg2, type);
+}
- /* If the COMMON block we are trying to add has a blank
- name (i.e. "#BLNK_COM") then we set it to __BLANK
- because the darn "#" character makes GDB's input
- parser have fits. */
+/* 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);
- if (strcmp (name, BLANK_COMMON_NAME_ORIGINAL) == 0
- || strcmp (name, BLANK_COMMON_NAME_MF77) == 0)
+ switch (type->code ())
{
-
- xfree (name);
- name = alloca (strlen (BLANK_COMMON_NAME_LOCAL) + 1);
- strcpy (name, BLANK_COMMON_NAME_LOCAL);
+ 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"));
}
- tmp = allocate_saved_f77_common_node ();
+ 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)));
+}
- local_copy_func_stab = xmalloc (strlen (func_stab) + 1);
- strcpy (local_copy_func_stab, func_stab);
+/* A helper function for UNOP_FORTRAN_ALLOCATED. */
- tmp->name = xmalloc (strlen (name) + 1);
+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);
+}
- /* local_copy_func_stab is a stabstring, let us first extract the
- function name from the stab by NULLing out the ':' character. */
+/* See f-exp.h. */
+struct value *
+eval_op_f_rank (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside,
+ enum exp_opcode op,
+ struct value *arg1)
+{
+ gdb_assert (op == UNOP_FORTRAN_RANK);
+
+ 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);
+}
- c = NULL;
- c = strchr (local_copy_func_stab, ':');
+/* A helper function for UNOP_FORTRAN_LOC. */
- if (c)
- *c = '\0';
+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
- error (_("Malformed function STAB found in add_common_block()"));
+ result_type = builtin_f_type (exp->gdbarch)->builtin_integer_s8;
+ LONGEST result_value = value_address (arg1);
+ return value_from_longest (result_type, result_value);
+}
- tmp->owning_function = xmalloc (strlen (local_copy_func_stab) + 1);
-
- strcpy (tmp->owning_function, local_copy_func_stab);
-
- strcpy (tmp->name, name);
- tmp->offset = offset;
- tmp->next = NULL;
- tmp->entries = NULL;
- tmp->secnum = secnum;
+namespace expr
+{
- current_common = tmp;
+/* 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. */
- if (head_common_list == NULL)
+value *
+fortran_undetermined::value_subarray (value *array,
+ struct expression *exp,
+ enum noside noside)
+{
+ 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 ();
+
+ /* 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)
{
- head_common_list = tail_common_list = tmp;
+ 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
{
- tail_common_list->next = tmp;
- tail_common_list = tmp;
+ if (type_not_associated (original_array_type))
+ error (_("array not associated"));
+ else if (type_not_allocated (original_array_type))
+ error (_("array not allocated"));
}
-}
-#endif
-/* The following function simply enters a given common entry onto
- the "current_common" block that has been saved away. */
-
-#if 0
-static void
-add_common_entry (struct symbol *entry_sym_ptr)
-{
- COMMON_ENTRY_PTR tmp;
+ /* 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 order of this list is important, since
- we expect the entries to appear in decl.
- order when we later issue "info common" calls */
+ /* The byte stride for this dimension of the slice. */
+ LONGEST stride;
- tmp = allocate_common_entry_node ();
+ struct type *index;
+ };
- tmp->next = NULL;
- tmp->symbol = entry_sym_ptr;
+ /* The dimensions of the resulting slice. */
+ std::vector<slice_dim> slice_dims;
- if (current_common == NULL)
- error (_("Attempt to add COMMON entry with no block open!"));
- else
+ /* 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)
{
- if (current_common->entries == NULL)
+ /* 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)
{
- current_common->entries = tmp;
- current_common->end_of_entries = tmp;
+ 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
{
- current_common->end_of_entries->next = tmp;
- current_common->end_of_entries = tmp;
+ /* 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;
}
}
-}
-#endif
-
-/* This routine finds the first encountred COMMON block named "name" */
-#if 0
-static SAVED_F77_COMMON_PTR
-find_first_common_named (char *name)
-{
+ /* 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);
+ }
- SAVED_F77_COMMON_PTR tmp;
+ 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"));
+ }
- tmp = head_common_list;
+ /* 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);
+ }
- while (tmp != NULL)
+ /* 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 (strcmp (tmp->name, name) == 0)
- return (tmp);
+ 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
- tmp = tmp->next;
+ error (_("cannot subscript arrays that are not in memory"));
}
- return (NULL);
-}
-#endif
-/* This routine finds the first encountred COMMON block named "name"
- that belongs to function funcname */
+ return array;
+}
-SAVED_F77_COMMON_PTR
-find_common_for_function (char *name, char *funcname)
+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 ();
- SAVED_F77_COMMON_PTR tmp;
+ 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);
- tmp = head_common_list;
+ 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);
+ }
- while (tmp != NULL)
+ 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 (DEPRECATED_STREQ (tmp->name, name)
- && DEPRECATED_STREQ (tmp->owning_function, funcname))
- return (tmp);
+ if (lbound_p)
+ error (_("LBOUND second argument should be an integer"));
else
- tmp = tmp->next;
+ error (_("UBOUND second argument should be an integer"));
}
- return (NULL);
-}
+ return fortran_bounds_for_dimension (lbound_p, exp->gdbarch, arg1, arg2);
+}
-#if 0
+} /* namespace expr */
-/* The following function is called to patch up the offsets
- for the statics contained in the COMMON block named
- "name." */
+/* See language.h. */
-static void
-patch_common_entries (SAVED_F77_COMMON_PTR blk, CORE_ADDR offset, int secnum)
+void
+f_language::language_arch_info (struct gdbarch *gdbarch,
+ struct language_arch_info *lai) const
{
- COMMON_ENTRY_PTR entry;
+ const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
- blk->offset = offset; /* Keep this around for future use. */
+ /* Helper function to allow shorter lines below. */
+ auto add = [&] (struct type * t)
+ {
+ lai->add_primitive_type (t);
+ };
- entry = blk->entries;
+ add (builtin->builtin_character);
+ add (builtin->builtin_logical);
+ add (builtin->builtin_logical_s1);
+ add (builtin->builtin_logical_s2);
+ add (builtin->builtin_logical_s8);
+ add (builtin->builtin_real);
+ add (builtin->builtin_real_s8);
+ add (builtin->builtin_real_s16);
+ 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");
+}
- while (entry != NULL)
- {
- SYMBOL_VALUE (entry->symbol) += offset;
- SYMBOL_SECTION (entry->symbol) = secnum;
+/* See language.h. */
- entry = entry->next;
- }
- blk->secnum = secnum;
+unsigned int
+f_language::search_name_hash (const char *name) const
+{
+ return cp_search_name_hash (name);
}
-/* Patch all commons named "name" that need patching.Since COMMON
- blocks occur with relative infrequency, we simply do a linear scan on
- the name. Eventually, the best way to do this will be a
- hashed-lookup. Secnum is the section number for the .bss section
- (which is where common data lives). */
+/* See language.h. */
-static void
-patch_all_commons_by_name (char *name, CORE_ADDR offset, int secnum)
+struct block_symbol
+f_language::lookup_symbol_nonlocal (const char *name,
+ const struct block *block,
+ const domain_enum domain) const
{
+ return cp_lookup_symbol_nonlocal (this, name, block, domain);
+}
- SAVED_F77_COMMON_PTR tmp;
-
- /* For blank common blocks, change the canonical reprsentation
- of a blank name */
+/* See language.h. */
- if (strcmp (name, BLANK_COMMON_NAME_ORIGINAL) == 0
- || strcmp (name, BLANK_COMMON_NAME_MF77) == 0)
- {
- xfree (name);
- name = alloca (strlen (BLANK_COMMON_NAME_LOCAL) + 1);
- strcpy (name, BLANK_COMMON_NAME_LOCAL);
- }
+symbol_name_matcher_ftype *
+f_language::get_symbol_name_matcher_inner
+ (const lookup_name_info &lookup_name) const
+{
+ return cp_get_symbol_name_matcher (lookup_name);
+}
- tmp = head_common_list;
+/* Single instance of the Fortran language class. */
- while (tmp != NULL)
- {
- if (COMMON_NEEDS_PATCHING (tmp))
- if (strcmp (tmp->name, name) == 0)
- patch_common_entries (tmp, offset, secnum);
+static f_language f_language_defn;
- tmp = tmp->next;
- }
-}
-#endif
-
-/* This macro adds the symbol-number for the start of the function
- (the symbol number of the .bf) referenced by symnum_fcn to a
- list. This list, in reality should be a FIFO queue but since
- #line pragmas sometimes cause line ranges to get messed up
- we simply create a linear list. This list can then be searched
- first by a queueing algorithm and upon failure fall back to
- a linear scan. */
-
-#if 0
-#define ADD_BF_SYMNUM(bf_sym,fcn_sym) \
- \
- if (saved_bf_list == NULL) \
-{ \
- tmp_bf_ptr = allocate_saved_bf_node(); \
- \
- tmp_bf_ptr->symnum_bf = (bf_sym); \
- tmp_bf_ptr->symnum_fcn = (fcn_sym); \
- tmp_bf_ptr->next = NULL; \
- \
- current_head_bf_list = saved_bf_list = tmp_bf_ptr; \
- saved_bf_list_end = tmp_bf_ptr; \
- } \
-else \
-{ \
- tmp_bf_ptr = allocate_saved_bf_node(); \
- \
- tmp_bf_ptr->symnum_bf = (bf_sym); \
- tmp_bf_ptr->symnum_fcn = (fcn_sym); \
- tmp_bf_ptr->next = NULL; \
- \
- saved_bf_list_end->next = tmp_bf_ptr; \
- saved_bf_list_end = tmp_bf_ptr; \
- }
-#endif
-
-/* This function frees the entire (.bf,function) list */
-
-#if 0
-static void
-clear_bf_list (void)
+static void *
+build_fortran_types (struct gdbarch *gdbarch)
{
+ struct builtin_f_type *builtin_f_type
+ = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
- SAVED_BF_PTR tmp = saved_bf_list;
- SAVED_BF_PTR next = NULL;
+ builtin_f_type->builtin_void
+ = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
+
+ builtin_f_type->builtin_character
+ = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
+
+ 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");
+
+ builtin_f_type->builtin_logical_s8
+ = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
+ "logical*8");
+
+ builtin_f_type->builtin_integer
+ = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
+ "integer");
+
+ builtin_f_type->builtin_logical
+ = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
+ "logical*4");
+
+ builtin_f_type->builtin_real
+ = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
+ "real", 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
+ = arch_float_type (gdbarch, 128, "real*16", fmt);
+ else if (gdbarch_long_double_bit (gdbarch) == 128)
+ builtin_f_type->builtin_real_s16
+ = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
+ "real*16", gdbarch_long_double_format (gdbarch));
+ else
+ builtin_f_type->builtin_real_s16
+ = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
- while (tmp != NULL)
- {
- next = tmp->next;
- xfree (tmp);
- tmp = next;
- }
- saved_bf_list = NULL;
-}
-#endif
+ 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);
-int global_remote_debug;
+ 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");
+ else
+ builtin_f_type->builtin_complex_s32
+ = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
-#if 0
+ return builtin_f_type;
+}
+
+static struct gdbarch_data *f_type_data;
-static long
-get_bf_for_fcn (long the_function)
+const struct builtin_f_type *
+builtin_f_type (struct gdbarch *gdbarch)
{
- SAVED_BF_PTR tmp;
- int nprobes = 0;
+ return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
+}
- /* First use a simple queuing algorithm (i.e. look and see if the
- item at the head of the queue is the one you want) */
+/* Command-list for the "set/show fortran" prefix command. */
+static struct cmd_list_element *set_fortran_list;
+static struct cmd_list_element *show_fortran_list;
- if (saved_bf_list == NULL)
- internal_error (__FILE__, __LINE__,
- _("cannot get .bf node off empty list"));
+void _initialize_f_language ();
+void
+_initialize_f_language ()
+{
+ f_type_data = gdbarch_data_register_post_init (build_fortran_types);
- if (current_head_bf_list != NULL)
- if (current_head_bf_list->symnum_fcn == the_function)
- {
- if (global_remote_debug)
- fprintf_unfiltered (gdb_stderr, "*");
+ 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_boolean_cmd ("repack-array-slices", class_vars,
+ &repack_array_slices, _("\
+Enable or disable repacking of non-contiguous array slices."), _("\
+Show whether non-contiguous array slices are repacked."), _("\
+When the user requests a slice of a Fortran array then we can either return\n\
+a descriptor that describes the array in place (using the original array data\n\
+in its existing location) or the original data can be repacked (copied) to a\n\
+new location.\n\
+\n\
+When the content of the array slice is contiguous within the original array\n\
+then the result will never be repacked, but when the data for the new array\n\
+is non-contiguous within the original array repacking will only be performed\n\
+when this setting is on."),
+ NULL,
+ show_repack_array_slices,
+ &set_fortran_list, &show_fortran_list);
+
+ /* Debug Fortran's array slicing logic. */
+ add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance,
+ &fortran_array_slicing_debug, _("\
+Set debugging of Fortran array slicing."), _("\
+Show debugging of Fortran array slicing."), _("\
+When on, debugging of Fortran array slicing is enabled."),
+ NULL,
+ show_fortran_array_slicing_debug,
+ &setdebuglist, &showdebuglist);
+}
- tmp = current_head_bf_list;
- current_head_bf_list = current_head_bf_list->next;
- return (tmp->symnum_bf);
- }
+/* Ensures that function argument VALUE is in the appropriate form to
+ pass to a Fortran function. Returns a possibly new value that should
+ be used instead of VALUE.
- /* If the above did not work (probably because #line directives were
- used in the sourcefile and they messed up our internal tables) we now do
- the ugly linear scan */
+ When IS_ARTIFICIAL is true this indicates an artificial argument,
+ e.g. hidden string lengths which the GNU Fortran argument passing
+ convention specifies as being passed by value.
- if (global_remote_debug)
- fprintf_unfiltered (gdb_stderr, "\ndefaulting to linear scan\n");
+ When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
+ value is already in target memory then return a value that is a pointer
+ to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
+ space in the target, copy VALUE in, and return a pointer to the in
+ memory copy. */
- nprobes = 0;
- tmp = saved_bf_list;
- while (tmp != NULL)
+static struct value *
+fortran_argument_convert (struct value *value, bool is_artificial)
+{
+ if (!is_artificial)
+ {
+ /* If the value is not in the inferior e.g. registers values,
+ convenience variables and user input. */
+ if (VALUE_LVAL (value) != lval_memory)
+ {
+ struct type *type = value_type (value);
+ 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);
+ return value_addr (val);
+ }
+ else
+ return value_addr (value); /* Program variables, e.g. arrays. */
+ }
+ 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,
+ 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)
{
- nprobes++;
- if (tmp->symnum_fcn == the_function)
+ expr::unop_addr_operation *addrop
+ = dynamic_cast<expr::unop_addr_operation *> (subexp);
+ if (addrop != nullptr)
{
- if (global_remote_debug)
- fprintf_unfiltered (gdb_stderr, "Found in %d probes\n", nprobes);
- current_head_bf_list = tmp->next;
- return (tmp->symnum_bf);
+ subexp = addrop->get_expression ().get ();
+ is_artificial = false;
}
- tmp = tmp->next;
}
- return (-1);
+ struct value *arg_val = subexp->evaluate_with_coercion (exp, noside);
+ return fortran_argument_convert (arg_val, is_artificial);
}
-static SAVED_FUNCTION_PTR saved_function_list = NULL;
-static SAVED_FUNCTION_PTR saved_function_list_end = NULL;
+/* See f-lang.h. */
-static void
-clear_function_list (void)
+struct type *
+fortran_preserve_arg_pointer (struct value *arg, struct type *type)
+{
+ if (value_type (arg)->code () == TYPE_CODE_PTR)
+ return value_type (arg);
+ return type;
+}
+
+/* See f-lang.h. */
+
+CORE_ADDR
+fortran_adjust_dynamic_array_base_address_hack (struct type *type,
+ CORE_ADDR address)
{
- SAVED_FUNCTION_PTR tmp = saved_function_list;
- SAVED_FUNCTION_PTR next = NULL;
+ gdb_assert (type->code () == TYPE_CODE_ARRAY);
+
+ /* We can't adjust the base address for arrays that have no content. */
+ if (type_not_allocated (type) || type_not_associated (type))
+ return address;
- while (tmp != NULL)
+ int ndimensions = calc_f77_array_dims (type);
+ LONGEST total_offset = 0;
+
+ /* Walk through each of the dimensions of this array type and figure out
+ if any of the dimensions are "backwards", that is the base address
+ for this dimension points to the element at the highest memory
+ address and the stride is negative. */
+ struct type *tmp_type = type;
+ for (int i = 0 ; i < ndimensions; ++i)
{
- next = tmp->next;
- xfree (tmp);
- tmp = next;
+ /* Grab the range for this dimension and extract the lower and upper
+ bounds. */
+ tmp_type = check_typedef (tmp_type);
+ struct type *range_type = tmp_type->index_type ();
+ LONGEST lowerbound, upperbound, stride;
+ if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
+ error ("failed to get range bounds");
+
+ /* Figure out the stride for this dimension. */
+ struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (tmp_type));
+ stride = tmp_type->index_type ()->bounds ()->bit_stride ();
+ if (stride == 0)
+ stride = type_length_units (elt_type);
+ else
+ {
+ int unit_size
+ = gdbarch_addressable_memory_unit_size (elt_type->arch ());
+ stride /= (unit_size * 8);
+ }
+
+ /* If this dimension is "backward" then figure out the offset
+ adjustment required to point to the element at the lowest memory
+ address, and add this to the total offset. */
+ LONGEST offset = 0;
+ if (stride < 0 && lowerbound < upperbound)
+ offset = (upperbound - lowerbound) * stride;
+ total_offset += offset;
+ tmp_type = TYPE_TARGET_TYPE (tmp_type);
}
- saved_function_list = NULL;
+ /* Adjust the address of this object and return it. */
+ address += total_offset;
+ return address;
}
-#endif
projects / deliverable / binutils-gdb.git / blobdiff