Change how DWARF index writer finds address map
[deliverable/binutils-gdb.git] / gdb / f-lang.c
index c60bfdb27ae0ca323c5ca90119d7c203ab1a7525..0c49420e1f1fe82a7abb562b4f22992437aef600 100644 (file)
@@ -1,7 +1,6 @@
 /* Fortran language support routines for GDB, the GNU debugger.
 
-   Copyright (C) 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003,
-   2004, 2005, 2007, 2008, 2009 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).
    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. */
+/* Whether GDB should repack array slices created by the user.  */
+static bool repack_array_slices = false;
 
-struct saved_fcn
-  {
-    long line_offset;          /* Line offset for function */
-    struct saved_fcn *next;
-  };
+/* 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);
+}
 
+/* Debugging of Fortran's array slicing.  */
+static bool fortran_array_slicing_debug = false;
 
-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;
-  };
-
-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 void f_printchar (int c, struct type *type, struct ui_file * stream);
-static void f_emit_char (int c, struct type *type,
-                        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 type *type, 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 type *type, struct ui_file *stream)
+fortran_require_array (struct type *type, bool lbound_p)
 {
-  fputs_filtered ("'", stream);
-  LA_EMIT_CHAR (c, type, 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, struct type *type, const gdb_byte *string,
-           unsigned int length, int force_ellipses,
-           const struct value_print_options *options)
+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;
-  int width = TYPE_LENGTH (type);
-
-  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 < options->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 > options->repeat_count_threshold)
-       {
-         if (in_quotes)
-           {
-             if (options->inspect_it)
-               fputs_filtered ("\\', ", stream);
-             else
-               fputs_filtered ("', ", stream);
-             in_quotes = 0;
-           }
-         f_printchar (string[i], type, stream);
-         fprintf_filtered (stream, " <repeats %u times>", reps);
-         i = rep1 - 1;
-         things_printed += options->repeat_count_threshold;
-         need_comma = 1;
-       }
-      else
-       {
-         if (!in_quotes)
-           {
-             if (options->inspect_it)
-               fputs_filtered ("\\'", stream);
-             else
-               fputs_filtered ("'", stream);
-             in_quotes = 1;
-           }
-         LA_EMIT_CHAR (string[i], type, stream, '"');
-         ++things_printed;
+         return value_from_longest (bound_type, b);
        }
-    }
 
-  /* Terminate the quotes if necessary.  */
-  if (in_quotes)
-    {
-      if (options->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
 
-/* 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}
+/* Return the number of dimensions for a Fortran array or string.  */
+
+int
+calc_f77_array_dims (struct type *array_type)
+{
+  int ndimen = 1;
+  struct type *tmp_type;
+
+  if ((array_type->code () == TYPE_CODE_STRING))
+    return 1;
+
+  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)))
+    {
+      if (tmp_type->code () == TYPE_CODE_ARRAY)
+       ++ndimen;
+    }
+  return ndimen;
+}
+
+/* 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;
-
-  lai->bool_type_symbol = "logical";
-  lai->bool_type_default = builtin->builtin_logical_s2;
-}
-
-/* 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 *,
-                         const struct value_print_options *);
-
-const struct language_defn f_language_defn =
-{
-  "fortran",
-  language_fortran,
-  range_check_on,
-  type_check_on,
-  case_sensitive_off,
-  array_column_major,
-  macro_expansion_no,
-  &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_print_type,                        /* Print a type using appropriate syntax */
-  default_print_typedef,       /* Print a typedef using appropriate syntax */
-  f_val_print,                 /* Print a value using appropriate syntax */
-  c_value_print,               /* FIXME */
-  NULL,                                /* Language specific skip_trampoline */
-  NULL,                        /* name_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 */
-  default_word_break_characters,
-  default_make_symbol_completion_list,
-  f_language_arch_info,
-  default_print_array_index,
-  default_pass_by_reference,
-  default_get_string,
-  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);
+
+  /* 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);
+    }
 
-  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 (gdbarch) / TARGET_CHAR_BIT,
-              0, "integer*2", (struct objfile *) NULL);
-
-  builtin_f_type->builtin_logical_s2 =
-    init_type (TYPE_CODE_BOOL,
-              gdbarch_short_bit (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 (gdbarch) / TARGET_CHAR_BIT,
-              0, "integer", (struct objfile *) NULL);
-
-  builtin_f_type->builtin_logical =
-    init_type (TYPE_CODE_BOOL, 
-              gdbarch_int_bit (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 (gdbarch) / TARGET_CHAR_BIT,
-              0,
-              "real", (struct objfile *) NULL);
-
-  builtin_f_type->builtin_real_s8 =
-    init_type (TYPE_CODE_FLT,
-              gdbarch_double_bit (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 (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 (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 (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 (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 two argument case, is POINTER associated with TARGET?  */
 
-  return builtin_f_type;
+  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);
+    }
 
-  add_language (&f_language_defn);
+  /* 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);
+    }
+
+  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"));
+
+      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);
+    }
 
-  new = (SAVED_FUNCTION *) xmalloc (sizeof (SAVED_FUNCTION));
-  return (new);
+  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));
+}
 
-  new = (COMMON_ENTRY_PTR) xmalloc (sizeof (COMMON_ENTRY));
-  return (new);
+/* A helper function for UNOP_FORTRAN_CEILING.  */
+
+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.  */
 
-#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
-                                                        */
+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);
+}
+
+/* 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 ();
+       }
+    }
 
-  tmp = head_common_list;
+  switch (code)
+    {
+    case TYPE_CODE_ARRAY:
+    case TYPE_CODE_STRING:
+      return value_subarray (callee, exp, noside);
 
-  while (tmp != NULL)
+    case TYPE_CODE_PTR:
+    case TYPE_CODE_FUNC:
+    case TYPE_CODE_INTERNAL_FUNCTION:
+      {
+       /* It's a function call.  Allocate arg vector, including
+          space for the function to be called in argvec[0] and a
+          termination NULL.  */
+       const std::vector<operation_up> &actual (std::get<1> (m_storage));
+       std::vector<value *> argvec (actual.size ());
+       bool is_internal_func = (code == TYPE_CODE_INTERNAL_FUNCTION);
+       for (int tem = 0; tem < argvec.size (); tem++)
+         argvec[tem] = fortran_prepare_argument (exp, actual[tem].get (),
+                                                 tem, is_internal_func,
+                                                 value_type (callee),
+                                                 noside);
+       return evaluate_subexp_do_call (exp, noside, callee, argvec,
+                                       nullptr, expect_type);
+      }
+
+    default:
+      error (_("Cannot perform substring on this type"));
+    }
+}
+
+value *
+fortran_bound_1arg::evaluate (struct type *expect_type,
+                             struct expression *exp,
+                             enum noside noside)
+{
+  bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
+  value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
+  fortran_require_array (value_type (arg1), lbound_p);
+  return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1);
+}
+
+value *
+fortran_bound_2arg::evaluate (struct type *expect_type,
+                             struct expression *exp,
+                             enum noside noside)
+{
+  bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
+  value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
+  fortran_require_array (value_type (arg1), lbound_p);
+
+  /* User asked for the bounds of a specific dimension of the array.  */
+  value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
+  struct type *type = check_typedef (value_type (arg2));
+  if (type->code () != TYPE_CODE_INT)
     {
-      if (strcmp (tmp->name, name) == 0
-         && strcmp (tmp->owning_function, funcname) == 0)
-       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 long
-get_bf_for_fcn (long the_function)
+static struct gdbarch_data *f_type_data;
+
+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)
 {
-  SAVED_FUNCTION_PTR tmp = saved_function_list;
-  SAVED_FUNCTION_PTR next = NULL;
+  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)
+{
+  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
This page took 0.047548 seconds and 4 git commands to generate.