X-Git-Url: http://git.efficios.com/?a=blobdiff_plain;f=gdb%2Ff-valprint.c;h=35dc90dcb0f6471dc1013ea74edea3bc0889e067;hb=27e4fac77ea57b288ac1e08d936d9a8fdc01a1ee;hp=5d86798f1b1af0f4693f7a827a59824a3c05b69c;hpb=806048c68af789ffb76e44fca706a7915cfdb9aa;p=deliverable%2Fbinutils-gdb.git

diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c
index 5d86798f1b..35dc90dcb0 100644
--- a/gdb/f-valprint.c
+++ b/gdb/f-valprint.c
@@ -1,7 +1,6 @@
 /* Support for printing Fortran values for GDB, the GNU debugger.
 
-   Copyright 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2003, 2005 Free
-   Software Foundation, Inc.
+   Copyright (C) 1993-2019 Free Software Foundation, Inc.
 
    Contributed by Motorola.  Adapted from the C definitions by Farooq Butt
    (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
@@ -10,7 +9,7 @@
 
    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
-   the Free Software Foundation; either version 2 of the License, or
+   the Free Software Foundation; either version 3 of the License, or
    (at your option) any later version.
 
    This program is distributed in the hope that it will be useful,
@@ -19,12 +18,9 @@
    GNU General Public License for more details.
 
    You should have received a copy of the GNU General Public License
-   along with this program; if not, write to the Free Software
-   Foundation, Inc., 59 Temple Place - Suite 330,
-   Boston, MA 02111-1307, USA.  */
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
 
 #include "defs.h"
-#include "gdb_string.h"
 #include "symtab.h"
 #include "gdbtypes.h"
 #include "expression.h"
@@ -36,161 +32,49 @@
 #include "gdbcore.h"
 #include "command.h"
 #include "block.h"
+#include "dictionary.h"
+#include "cli/cli-style.h"
+#include "gdbarch.h"
 
-#if 0
-static int there_is_a_visible_common_named (char *);
-#endif
-
-extern void _initialize_f_valprint (void);
-static void info_common_command (char *, int);
-static void list_all_visible_commons (char *);
-static void f77_create_arrayprint_offset_tbl (struct type *,
-					      struct ui_file *);
 static void f77_get_dynamic_length_of_aggregate (struct type *);
 
 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
 
 /* Array which holds offsets to be applied to get a row's elements
-   for a given array. Array also holds the size of each subarray.  */
-
-/* The following macro gives us the size of the nth dimension, Where 
-   n is 1 based. */
-
-#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
+   for a given array.  Array also holds the size of each subarray.  */
 
-/* The following gives us the offset for row n where n is 1-based. */
-
-#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
-
-int
-f77_get_dynamic_lowerbound (struct type *type, int *lower_bound)
+LONGEST
+f77_get_lowerbound (struct type *type)
 {
-  CORE_ADDR current_frame_addr;
-  CORE_ADDR ptr_to_lower_bound;
+  if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type))
+    error (_("Lower bound may not be '*' in F77"));
 
-  switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
-    {
-    case BOUND_BY_VALUE_ON_STACK:
-      current_frame_addr = get_frame_base (deprecated_selected_frame);
-      if (current_frame_addr > 0)
-	{
-	  *lower_bound =
-	    read_memory_integer (current_frame_addr +
-				 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
-				 4);
-	}
-      else
-	{
-	  *lower_bound = DEFAULT_LOWER_BOUND;
-	  return BOUND_FETCH_ERROR;
-	}
-      break;
-
-    case BOUND_SIMPLE:
-      *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type);
-      break;
-
-    case BOUND_CANNOT_BE_DETERMINED:
-      error (_("Lower bound may not be '*' in F77"));
-      break;
-
-    case BOUND_BY_REF_ON_STACK:
-      current_frame_addr = get_frame_base (deprecated_selected_frame);
-      if (current_frame_addr > 0)
-	{
-	  ptr_to_lower_bound =
-	    read_memory_typed_address (current_frame_addr +
-				       TYPE_ARRAY_LOWER_BOUND_VALUE (type),
-				       builtin_type_void_data_ptr);
-	  *lower_bound = read_memory_integer (ptr_to_lower_bound, 4);
-	}
-      else
-	{
-	  *lower_bound = DEFAULT_LOWER_BOUND;
-	  return BOUND_FETCH_ERROR;
-	}
-      break;
-
-    case BOUND_BY_REF_IN_REG:
-    case BOUND_BY_VALUE_IN_REG:
-    default:
-      error (_("??? unhandled dynamic array bound type ???"));
-      break;
-    }
-  return BOUND_FETCH_OK;
+  return TYPE_ARRAY_LOWER_BOUND_VALUE (type);
 }
 
-int
-f77_get_dynamic_upperbound (struct type *type, int *upper_bound)
+LONGEST
+f77_get_upperbound (struct type *type)
 {
-  CORE_ADDR current_frame_addr = 0;
-  CORE_ADDR ptr_to_upper_bound;
-
-  switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
+  if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
     {
-    case BOUND_BY_VALUE_ON_STACK:
-      current_frame_addr = get_frame_base (deprecated_selected_frame);
-      if (current_frame_addr > 0)
-	{
-	  *upper_bound =
-	    read_memory_integer (current_frame_addr +
-				 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
-				 4);
-	}
-      else
-	{
-	  *upper_bound = DEFAULT_UPPER_BOUND;
-	  return BOUND_FETCH_ERROR;
-	}
-      break;
-
-    case BOUND_SIMPLE:
-      *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
-      break;
-
-    case BOUND_CANNOT_BE_DETERMINED:
-      /* we have an assumed size array on our hands. Assume that 
-         upper_bound == lower_bound so that we show at least 
-         1 element.If the user wants to see more elements, let 
-         him manually ask for 'em and we'll subscript the 
-         array and show him */
-      f77_get_dynamic_lowerbound (type, upper_bound);
-      break;
-
-    case BOUND_BY_REF_ON_STACK:
-      current_frame_addr = get_frame_base (deprecated_selected_frame);
-      if (current_frame_addr > 0)
-	{
-	  ptr_to_upper_bound =
-	    read_memory_typed_address (current_frame_addr +
-				       TYPE_ARRAY_UPPER_BOUND_VALUE (type),
-				       builtin_type_void_data_ptr);
-	  *upper_bound = read_memory_integer (ptr_to_upper_bound, 4);
-	}
-      else
-	{
-	  *upper_bound = DEFAULT_UPPER_BOUND;
-	  return BOUND_FETCH_ERROR;
-	}
-      break;
+      /* We have an assumed size array on our hands.  Assume that
+	 upper_bound == lower_bound so that we show at least 1 element.
+	 If the user wants to see more elements, let him manually ask for 'em
+	 and we'll subscript the array and show him.  */
 
-    case BOUND_BY_REF_IN_REG:
-    case BOUND_BY_VALUE_IN_REG:
-    default:
-      error (_("??? unhandled dynamic array bound type ???"));
-      break;
+      return f77_get_lowerbound (type);
     }
-  return BOUND_FETCH_OK;
+
+  return TYPE_ARRAY_UPPER_BOUND_VALUE (type);
 }
 
-/* Obtain F77 adjustable array dimensions */
+/* Obtain F77 adjustable array dimensions.  */
 
 static void
 f77_get_dynamic_length_of_aggregate (struct type *type)
 {
   int upper_bound = -1;
   int lower_bound = 1;
-  int retcode;
 
   /* Recursively go all the way down into a possibly multi-dimensional
      F77 array and get the bounds.  For simple arrays, this is pretty
@@ -206,123 +90,97 @@ f77_get_dynamic_length_of_aggregate (struct type *type)
     f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
 
   /* Recursion ends here, start setting up lengths.  */
-  retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
-  if (retcode == BOUND_FETCH_ERROR)
-    error (_("Cannot obtain valid array lower bound"));
+  lower_bound = f77_get_lowerbound (type);
+  upper_bound = f77_get_upperbound (type);
 
-  retcode = f77_get_dynamic_upperbound (type, &upper_bound);
-  if (retcode == BOUND_FETCH_ERROR)
-    error (_("Cannot obtain valid array upper bound"));
-
-  /* Patch in a valid length value. */
+  /* Patch in a valid length value.  */
 
   TYPE_LENGTH (type) =
-    (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
+    (upper_bound - lower_bound + 1)
+    * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
 }
 
-/* Function that sets up the array offset,size table for the array 
-   type "type".  */
-
-static void
-f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
-{
-  struct type *tmp_type;
-  int eltlen;
-  int ndimen = 1;
-  int upper, lower, retcode;
-
-  tmp_type = type;
-
-  while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
-    {
-      if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
-	fprintf_filtered (stream, "<assumed size array> ");
-
-      retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
-      if (retcode == BOUND_FETCH_ERROR)
-	error (_("Cannot obtain dynamic upper bound"));
-
-      retcode = f77_get_dynamic_lowerbound (tmp_type, &lower);
-      if (retcode == BOUND_FETCH_ERROR)
-	error (_("Cannot obtain dynamic lower bound"));
-
-      F77_DIM_SIZE (ndimen) = upper - lower + 1;
-
-      tmp_type = TYPE_TARGET_TYPE (tmp_type);
-      ndimen++;
-    }
-
-  /* Now we multiply eltlen by all the offsets, so that later we 
-     can print out array elements correctly.  Up till now we 
-     know an offset to apply to get the item but we also 
-     have to know how much to add to get to the next item */
-
-  ndimen--;
-  eltlen = TYPE_LENGTH (tmp_type);
-  F77_DIM_OFFSET (ndimen) = eltlen;
-  while (--ndimen > 0)
-    {
-      eltlen *= F77_DIM_SIZE (ndimen + 1);
-      F77_DIM_OFFSET (ndimen) = eltlen;
-    }
-}
-
-
-
 /* Actual function which prints out F77 arrays, Valaddr == address in 
    the superior.  Address == the address in the inferior.  */
 
 static void
 f77_print_array_1 (int nss, int ndimensions, struct type *type,
-		   const bfd_byte *valaddr, CORE_ADDR address,
-		   struct ui_file *stream, int format,
-		   int deref_ref, int recurse, enum val_prettyprint pretty,
+		   const gdb_byte *valaddr,
+		   int embedded_offset, CORE_ADDR address,
+		   struct ui_file *stream, int recurse,
+		   const struct value *val,
+		   const struct value_print_options *options,
 		   int *elts)
 {
+  struct type *range_type = TYPE_INDEX_TYPE (check_typedef (type));
+  CORE_ADDR addr = address + embedded_offset;
+  LONGEST lowerbound, upperbound;
   int i;
 
+  get_discrete_bounds (range_type, &lowerbound, &upperbound);
+
   if (nss != ndimensions)
     {
-      for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); i++)
+      struct gdbarch *gdbarch = get_type_arch (type);
+      size_t dim_size = type_length_units (TYPE_TARGET_TYPE (type));
+      int unit_size = gdbarch_addressable_memory_unit_size (gdbarch);
+      size_t byte_stride = TYPE_ARRAY_BIT_STRIDE (type) / (unit_size * 8);
+      if (byte_stride == 0)
+	byte_stride = dim_size;
+      size_t offs = 0;
+
+      for (i = lowerbound;
+	   (i < upperbound + 1 && (*elts) < options->print_max);
+	   i++)
 	{
+	  struct value *subarray = value_from_contents_and_address
+	    (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val)
+	     + offs, addr + offs);
+
 	  fprintf_filtered (stream, "( ");
-	  f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
-			     valaddr + i * F77_DIM_OFFSET (nss),
-			     address + i * F77_DIM_OFFSET (nss),
-			     stream, format, deref_ref, recurse, pretty, elts);
+	  f77_print_array_1 (nss + 1, ndimensions, value_type (subarray),
+			     value_contents_for_printing (subarray),
+			     value_embedded_offset (subarray),
+			     value_address (subarray),
+			     stream, recurse, subarray, options, elts);
+	  offs += byte_stride;
 	  fprintf_filtered (stream, ") ");
 	}
-      if (*elts >= print_max && i < F77_DIM_SIZE (nss)) 
+      if (*elts >= options->print_max && i < upperbound)
 	fprintf_filtered (stream, "...");
     }
   else
     {
-      for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < print_max; 
+      for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;
 	   i++, (*elts)++)
 	{
-	  val_print (TYPE_TARGET_TYPE (type),
-		     valaddr + i * F77_DIM_OFFSET (ndimensions),
-		     0,
-		     address + i * F77_DIM_OFFSET (ndimensions),
-		     stream, format, deref_ref, recurse, pretty);
+	  struct value *elt = value_subscript ((struct value *)val, i);
+
+	  val_print (value_type (elt),
+		     value_embedded_offset (elt),
+		     value_address (elt), stream, recurse,
+		     elt, options, current_language);
 
-	  if (i != (F77_DIM_SIZE (nss) - 1))
+	  if (i != upperbound)
 	    fprintf_filtered (stream, ", ");
 
-	  if ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1)))
+	  if ((*elts == options->print_max - 1)
+	      && (i != upperbound))
 	    fprintf_filtered (stream, "...");
 	}
     }
 }
 
 /* This function gets called to print an F77 array, we set up some 
-   stuff and then immediately call f77_print_array_1() */
+   stuff and then immediately call f77_print_array_1().  */
 
 static void
-f77_print_array (struct type *type, const bfd_byte *valaddr,
+f77_print_array (struct type *type, const gdb_byte *valaddr,
+		 int embedded_offset,
 		 CORE_ADDR address, struct ui_file *stream,
-		 int format, int deref_ref, int recurse,
-		 enum val_prettyprint pretty)
+		 int recurse,
+		 const struct value *val,
+		 const struct value_print_options *options)
 {
   int ndimensions;
   int elts = 0;
@@ -330,442 +188,300 @@ f77_print_array (struct type *type, const bfd_byte *valaddr,
   ndimensions = calc_f77_array_dims (type);
 
   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
-    error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
+    error (_("\
+Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 	   ndimensions, MAX_FORTRAN_DIMS);
 
-  /* Since F77 arrays are stored column-major, we set up an 
-     offset table to get at the various row's elements. The 
-     offset table contains entries for both offset and subarray size. */
-
-  f77_create_arrayprint_offset_tbl (type, stream);
-
-  f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
-		     deref_ref, recurse, pretty, &elts);
+  f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
+		     address, stream, recurse, val, options, &elts);
 }
 
 
-/* Print data of type TYPE located at VALADDR (within GDB), which came from
-   the inferior at address ADDRESS, onto stdio stream STREAM according to
-   FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
-   target byte order.
-
-   If the data are a string pointer, returns the number of string characters
-   printed.
+/* Decorations for Fortran.  */
 
-   If DEREF_REF is nonzero, then dereference references, otherwise just print
-   them like pointers.
-
-   The PRETTY parameter controls prettyprinting.  */
+static const struct generic_val_print_decorations f_decorations =
+{
+  "(",
+  ",",
+  ")",
+  ".TRUE.",
+  ".FALSE.",
+  "void",
+  "{",
+  "}"
+};
+
+/* See val_print for a description of the various parameters of this
+   function; they are identical.  */
 
-int
-f_val_print (struct type *type, const bfd_byte *valaddr, int embedded_offset,
-	     CORE_ADDR address, struct ui_file *stream, int format,
-	     int deref_ref, int recurse, enum val_prettyprint pretty)
+void
+f_val_print (struct type *type, int embedded_offset,
+	     CORE_ADDR address, struct ui_file *stream, int recurse,
+	     struct value *original_value,
+	     const struct value_print_options *options)
 {
-  unsigned int i = 0;	/* Number of characters printed */
+  struct gdbarch *gdbarch = get_type_arch (type);
+  int printed_field = 0; /* Number of fields printed.  */
   struct type *elttype;
-  LONGEST val;
   CORE_ADDR addr;
+  int index;
+  const gdb_byte *valaddr =value_contents_for_printing (original_value);
 
-  CHECK_TYPEDEF (type);
+  type = check_typedef (type);
   switch (TYPE_CODE (type))
     {
     case TYPE_CODE_STRING:
       f77_get_dynamic_length_of_aggregate (type);
-      LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
+      LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
+		       valaddr + embedded_offset,
+		       TYPE_LENGTH (type), NULL, 0, options);
       break;
 
     case TYPE_CODE_ARRAY:
-      fprintf_filtered (stream, "(");
-      f77_print_array (type, valaddr, address, stream, format,
-		       deref_ref, recurse, pretty);
-      fprintf_filtered (stream, ")");
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
+	{
+	  fprintf_filtered (stream, "(");
+	  f77_print_array (type, valaddr, embedded_offset,
+			   address, stream, recurse, original_value, options);
+	  fprintf_filtered (stream, ")");
+	}
+      else
+	{
+	  struct type *ch_type = TYPE_TARGET_TYPE (type);
+
+	  f77_get_dynamic_length_of_aggregate (type);
+	  LA_PRINT_STRING (stream, ch_type,
+			   valaddr + embedded_offset,
+			   TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
+			   NULL, 0, options);
+	}
       break;
 
     case TYPE_CODE_PTR:
-      if (format && format != 's')
+      if (options->format && options->format != 's')
 	{
-	  print_scalar_formatted (valaddr, type, format, 0, stream);
+	  val_print_scalar_formatted (type, embedded_offset,
+				      original_value, options, 0, stream);
 	  break;
 	}
       else
 	{
-	  addr = unpack_pointer (type, valaddr);
+	  int want_space = 0;
+
+	  addr = unpack_pointer (type, valaddr + embedded_offset);
 	  elttype = check_typedef (TYPE_TARGET_TYPE (type));
 
 	  if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 	    {
 	      /* Try to print what function it points to.  */
-	      print_address_demangle (addr, stream, demangle);
-	      /* Return value is irrelevant except for string pointers.  */
-	      return 0;
+	      print_function_pointer_address (options, gdbarch, addr, stream);
+	      return;
 	    }
 
-	  if (addressprint && format != 's')
-	    deprecated_print_address_numeric (addr, 1, stream);
+	  if (options->symbol_print)
+	    want_space = print_address_demangle (options, gdbarch, addr,
+						 stream, demangle);
+	  else if (options->addressprint && options->format != 's')
+	    {
+	      fputs_filtered (paddress (gdbarch, addr), stream);
+	      want_space = 1;
+	    }
 
 	  /* For a pointer to char or unsigned char, also print the string
 	     pointed to, unless pointer is null.  */
 	  if (TYPE_LENGTH (elttype) == 1
 	      && TYPE_CODE (elttype) == TYPE_CODE_INT
-	      && (format == 0 || format == 's')
+	      && (options->format == 0 || options->format == 's')
 	      && addr != 0)
-	    i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
-
-	  /* Return number of characters printed, including the terminating
-	     '\0' if we reached the end.  val_print_string takes care including
-	     the terminating '\0' if necessary.  */
-	  return i;
-	}
-      break;
-
-    case TYPE_CODE_REF:
-      elttype = check_typedef (TYPE_TARGET_TYPE (type));
-      if (addressprint)
-	{
-	  CORE_ADDR addr
-	    = extract_typed_address (valaddr + embedded_offset, type);
-	  fprintf_filtered (stream, "@");
-	  deprecated_print_address_numeric (addr, 1, stream);
-	  if (deref_ref)
-	    fputs_filtered (": ", stream);
-	}
-      /* De-reference the reference.  */
-      if (deref_ref)
-	{
-	  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 	    {
-	      struct value *deref_val =
-	      value_at
-	      (TYPE_TARGET_TYPE (type),
-	       unpack_pointer (lookup_pointer_type (builtin_type_void),
-			       valaddr + embedded_offset));
-	      common_val_print (deref_val, stream, format, deref_ref, recurse,
-				pretty);
+	      if (want_space)
+		fputs_filtered (" ", stream);
+	      val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
+				stream, options);
 	    }
-	  else
-	    fputs_filtered ("???", stream);
-	}
-      break;
-
-    case TYPE_CODE_FUNC:
-      if (format)
-	{
-	  print_scalar_formatted (valaddr, type, format, 0, stream);
-	  break;
+	  return;
 	}
-      /* FIXME, we should consider, at least for ANSI C language, eliminating
-         the distinction made between FUNCs and POINTERs to FUNCs.  */
-      fprintf_filtered (stream, "{");
-      type_print (type, "", stream, -1);
-      fprintf_filtered (stream, "} ");
-      /* Try to print what function it points to, and its address.  */
-      print_address_demangle (address, stream, demangle);
       break;
 
     case TYPE_CODE_INT:
-      format = format ? format : output_format;
-      if (format)
-	print_scalar_formatted (valaddr, type, format, 0, stream);
-      else
+      if (options->format || options->output_format)
 	{
-	  val_print_type_code_int (type, valaddr, stream);
-	  /* C and C++ has no single byte int type, char is used instead.
-	     Since we don't know whether the value is really intended to
-	     be used as an integer or a character, print the character
-	     equivalent as well. */
-	  if (TYPE_LENGTH (type) == 1)
-	    {
-	      fputs_filtered (" ", stream);
-	      LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
-			     stream);
-	    }
-	}
-      break;
+	  struct value_print_options opts = *options;
 
-    case TYPE_CODE_FLT:
-      if (format)
-	print_scalar_formatted (valaddr, type, format, 0, stream);
+	  opts.format = (options->format ? options->format
+			 : options->output_format);
+	  val_print_scalar_formatted (type, embedded_offset,
+				      original_value, &opts, 0, stream);
+	}
       else
-	print_floating (valaddr, type, stream);
+	val_print_scalar_formatted (type, embedded_offset,
+				    original_value, options, 0, stream);
       break;
 
-    case TYPE_CODE_VOID:
-      fprintf_filtered (stream, "VOID");
-      break;
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+      /* Starting from the Fortran 90 standard, Fortran supports derived
+         types.  */
+      fprintf_filtered (stream, "( ");
+      for (index = 0; index < TYPE_NFIELDS (type); index++)
+        {
+	  struct value *field = value_field
+	    ((struct value *)original_value, index);
 
-    case TYPE_CODE_ERROR:
-      fprintf_filtered (stream, "<error type>");
-      break;
+	  struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, index));
 
-    case TYPE_CODE_RANGE:
-      /* FIXME, we should not ever have to print one of these yet.  */
-      fprintf_filtered (stream, "<range type>");
-      break;
 
-    case TYPE_CODE_BOOL:
-      format = format ? format : output_format;
-      if (format)
-	print_scalar_formatted (valaddr, type, format, 0, stream);
-      else
-	{
-	  val = 0;
-	  switch (TYPE_LENGTH (type))
+	  if (TYPE_CODE (field_type) != TYPE_CODE_FUNC)
 	    {
-	    case 1:
-	      val = unpack_long (builtin_type_f_logical_s1, valaddr);
-	      break;
+	      const char *field_name;
 
-	    case 2:
-	      val = unpack_long (builtin_type_f_logical_s2, valaddr);
-	      break;
+	      if (printed_field > 0)
+		fputs_filtered (", ", stream);
 
-	    case 4:
-	      val = unpack_long (builtin_type_f_logical, valaddr);
-	      break;
+	      field_name = TYPE_FIELD_NAME (type, index);
+	      if (field_name != NULL)
+		{
+		  fputs_filtered (field_name, stream);
+		  fputs_filtered (" = ", stream);
+		}
 
-	    default:
-	      error (_("Logicals of length %d bytes not supported"),
-		     TYPE_LENGTH (type));
+	      val_print (value_type (field),
+			 value_embedded_offset (field),
+			 value_address (field), stream, recurse + 1,
+			 field, options, current_language);
 
+	      ++printed_field;
 	    }
+	 }
+      fprintf_filtered (stream, " )");
+      break;     
 
-	  if (val == 0)
-	    fprintf_filtered (stream, ".FALSE.");
-	  else if (val == 1)
-	    fprintf_filtered (stream, ".TRUE.");
-	  else
-	    /* Not a legitimate logical type, print as an integer.  */
-	    {
-	      /* Bash the type code temporarily.  */
-	      TYPE_CODE (type) = TYPE_CODE_INT;
-	      f_val_print (type, valaddr, 0, address, stream, format,
-			   deref_ref, recurse, pretty);
-	      /* Restore the type code so later uses work as intended. */
-	      TYPE_CODE (type) = TYPE_CODE_BOOL;
-	    }
-	}
-      break;
-
-    case TYPE_CODE_COMPLEX:
-      switch (TYPE_LENGTH (type))
-	{
-	case 8:
-	  type = builtin_type_f_real;
-	  break;
-	case 16:
-	  type = builtin_type_f_real_s8;
-	  break;
-	case 32:
-	  type = builtin_type_f_real_s16;
-	  break;
-	default:
-	  error (_("Cannot print out complex*%d variables"), TYPE_LENGTH (type));
-	}
-      fputs_filtered ("(", stream);
-      print_floating (valaddr, type, stream);
-      fputs_filtered (",", stream);
-      print_floating (valaddr + TYPE_LENGTH (type), type, stream);
-      fputs_filtered (")", stream);
-      break;
-
+    case TYPE_CODE_REF:
+    case TYPE_CODE_FUNC:
+    case TYPE_CODE_FLAGS:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_RANGE:
     case TYPE_CODE_UNDEF:
-      /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
-         dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
-         and no complete type for struct foo in that file.  */
-      fprintf_filtered (stream, "<incomplete type>");
-      break;
-
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_CHAR:
     default:
-      error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
+      generic_val_print (type, embedded_offset, address,
+			 stream, recurse, original_value, options,
+			 &f_decorations);
+      break;
     }
-  gdb_flush (stream);
-  return 0;
 }
 
 static void
-list_all_visible_commons (char *funname)
+info_common_command_for_block (const struct block *block, const char *comname,
+			       int *any_printed)
 {
-  SAVED_F77_COMMON_PTR tmp;
-
-  tmp = head_common_list;
-
-  printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
-
-  while (tmp != NULL)
-    {
-      if (strcmp (tmp->owning_function, funname) == 0)
-	printf_filtered ("%s\n", tmp->name);
-
-      tmp = tmp->next;
-    }
+  struct block_iterator iter;
+  struct symbol *sym;
+  struct value_print_options opts;
+
+  get_user_print_options (&opts);
+
+  ALL_BLOCK_SYMBOLS (block, iter, sym)
+    if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
+      {
+	const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
+	size_t index;
+
+	gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
+
+	if (comname && (!sym->linkage_name ()
+	                || strcmp (comname, sym->linkage_name ()) != 0))
+	  continue;
+
+	if (*any_printed)
+	  putchar_filtered ('\n');
+	else
+	  *any_printed = 1;
+	if (sym->print_name ())
+	  printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
+			   sym->print_name ());
+	else
+	  printf_filtered (_("Contents of blank COMMON block:\n"));
+	
+	for (index = 0; index < common->n_entries; index++)
+	  {
+	    struct value *val = NULL;
+
+	    printf_filtered ("%s = ",
+			     common->contents[index]->print_name ());
+
+	    try
+	      {
+		val = value_of_variable (common->contents[index], block);
+		value_print (val, gdb_stdout, &opts);
+	      }
+
+	    catch (const gdb_exception_error &except)
+	      {
+		fprintf_styled (gdb_stdout, metadata_style.style (),
+				"<error reading variable: %s>",
+				except.what ());
+	      }
+
+	    putchar_filtered ('\n');
+	  }
+      }
 }
 
 /* This function is used to print out the values in a given COMMON 
-   block. It will always use the most local common block of the 
-   given name */
+   block.  It will always use the most local common block of the 
+   given name.  */
 
 static void
-info_common_command (char *comname, int from_tty)
+info_common_command (const char *comname, int from_tty)
 {
-  SAVED_F77_COMMON_PTR the_common;
-  COMMON_ENTRY_PTR entry;
   struct frame_info *fi;
-  char *funname = 0;
-  struct symbol *func;
+  const struct block *block;
+  int values_printed = 0;
 
   /* We have been told to display the contents of F77 COMMON 
      block supposedly visible in this function.  Let us 
      first make sure that it is visible and if so, let 
-     us display its contents */
+     us display its contents.  */
 
-  fi = deprecated_selected_frame;
-
-  if (fi == NULL)
-    error (_("No frame selected"));
+  fi = get_selected_frame (_("No frame selected"));
 
   /* The following is generally ripped off from stack.c's routine 
-     print_frame_info() */
+     print_frame_info().  */
 
-  func = find_pc_function (get_frame_pc (fi));
-  if (func)
-    {
-      /* In certain pathological cases, the symtabs give the wrong
-         function (when we are in the first function in a file which
-         is compiled without debugging symbols, the previous function
-         is compiled with debugging symbols, and the "foo.o" symbol
-         that is supposed to tell us where the file with debugging symbols
-         ends has been truncated by ar because it is longer than 15
-         characters).
-
-         So look in the minimal symbol tables as well, and if it comes
-         up with a larger address for the function use that instead.
-         I don't think this can ever cause any problems; there shouldn't
-         be any minimal symbols in the middle of a function.
-         FIXME:  (Not necessarily true.  What about text labels) */
-
-      struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
-
-      if (msymbol != NULL
-	  && (SYMBOL_VALUE_ADDRESS (msymbol)
-	      > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
-	funname = DEPRECATED_SYMBOL_NAME (msymbol);
-      else
-	funname = DEPRECATED_SYMBOL_NAME (func);
-    }
-  else
+  block = get_frame_block (fi, 0);
+  if (block == NULL)
     {
-      struct minimal_symbol *msymbol =
-      lookup_minimal_symbol_by_pc (get_frame_pc (fi));
-
-      if (msymbol != NULL)
-	funname = DEPRECATED_SYMBOL_NAME (msymbol);
-    }
-
-  /* If comname is NULL, we assume the user wishes to see the 
-     which COMMON blocks are visible here and then return */
-
-  if (comname == 0)
-    {
-      list_all_visible_commons (funname);
+      printf_filtered (_("No symbol table info available.\n"));
       return;
     }
 
-  the_common = find_common_for_function (comname, funname);
-
-  if (the_common)
+  while (block)
     {
-      if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
-	printf_filtered (_("Contents of blank COMMON block:\n"));
-      else
-	printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
-
-      printf_filtered ("\n");
-      entry = the_common->entries;
-
-      while (entry != NULL)
-	{
-	  printf_filtered ("%s = ", DEPRECATED_SYMBOL_NAME (entry->symbol));
-	  print_variable_value (entry->symbol, fi, gdb_stdout);
-	  printf_filtered ("\n");
-	  entry = entry->next;
-	}
+      info_common_command_for_block (block, comname, &values_printed);
+      /* After handling the function's top-level block, stop.  Don't
+         continue to its superblock, the block of per-file symbols.  */
+      if (BLOCK_FUNCTION (block))
+	break;
+      block = BLOCK_SUPERBLOCK (block);
     }
-  else
-    printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
-		     comname, funname);
-}
-
-/* This function is used to determine whether there is a
-   F77 common block visible at the current scope called 'comname'. */
-
-#if 0
-static int
-there_is_a_visible_common_named (char *comname)
-{
-  SAVED_F77_COMMON_PTR the_common;
-  struct frame_info *fi;
-  char *funname = 0;
-  struct symbol *func;
 
-  if (comname == NULL)
-    error (_("Cannot deal with NULL common name!"));
-
-  fi = deprecated_selected_frame;
-
-  if (fi == NULL)
-    error (_("No frame selected"));
-
-  /* The following is generally ripped off from stack.c's routine 
-     print_frame_info() */
-
-  func = find_pc_function (fi->pc);
-  if (func)
+  if (!values_printed)
     {
-      /* In certain pathological cases, the symtabs give the wrong
-         function (when we are in the first function in a file which
-         is compiled without debugging symbols, the previous function
-         is compiled with debugging symbols, and the "foo.o" symbol
-         that is supposed to tell us where the file with debugging symbols
-         ends has been truncated by ar because it is longer than 15
-         characters).
-
-         So look in the minimal symbol tables as well, and if it comes
-         up with a larger address for the function use that instead.
-         I don't think this can ever cause any problems; there shouldn't
-         be any minimal symbols in the middle of a function.
-         FIXME:  (Not necessarily true.  What about text labels) */
-
-      struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
-
-      if (msymbol != NULL
-	  && (SYMBOL_VALUE_ADDRESS (msymbol)
-	      > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
-	funname = DEPRECATED_SYMBOL_NAME (msymbol);
+      if (comname)
+	printf_filtered (_("No common block '%s'.\n"), comname);
       else
-	funname = DEPRECATED_SYMBOL_NAME (func);
+	printf_filtered (_("No common blocks.\n"));
     }
-  else
-    {
-      struct minimal_symbol *msymbol =
-      lookup_minimal_symbol_by_pc (fi->pc);
-
-      if (msymbol != NULL)
-	funname = DEPRECATED_SYMBOL_NAME (msymbol);
-    }
-
-  the_common = find_common_for_function (comname, funname);
-
-  return (the_common ? 1 : 0);
 }
-#endif
 
 void
 _initialize_f_valprint (void)
 {
   add_info ("common", info_common_command,
 	    _("Print out the values contained in a Fortran COMMON block."));
-  if (xdb_commands)
-    add_com ("lc", class_info, info_common_command,
-	     _("Print out the values contained in a Fortran COMMON block."));
 }