gdb/f-valprint.c

   1 /* Support for printing Fortran values for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-2021 Free Software Foundation, Inc.
   4
   5    Contributed by Motorola.  Adapted from the C definitions by Farooq Butt
   6    (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
   7
   8    This file is part of GDB.
   9
  10    This program is free software; you can redistribute it and/or modify
  11    it under the terms of the GNU General Public License as published by
  12    the Free Software Foundation; either version 3 of the License, or
  13    (at your option) any later version.
  14
  15    This program is distributed in the hope that it will be useful,
  16    but WITHOUT ANY WARRANTY; without even the implied warranty of
  17    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18    GNU General Public License for more details.
  19
  20    You should have received a copy of the GNU General Public License
  21    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  22
  23 #include "defs.h"
  24 #include "symtab.h"
  25 #include "gdbtypes.h"
  26 #include "expression.h"
  27 #include "value.h"
  28 #include "valprint.h"
  29 #include "language.h"
  30 #include "f-lang.h"
  31 #include "frame.h"
  32 #include "gdbcore.h"
  33 #include "command.h"
  34 #include "block.h"
  35 #include "dictionary.h"
  36 #include "cli/cli-style.h"
  37 #include "gdbarch.h"
  38 #include "f-array-walker.h"
  39
  40 static void f77_get_dynamic_length_of_aggregate (struct type *);
  41
  42 LONGEST
  43 f77_get_lowerbound (struct type *type)
  44 {
  45   if (type->bounds ()->low.kind () == PROP_UNDEFINED)
  46     error (_("Lower bound may not be '*' in F77"));
  47
  48   return type->bounds ()->low.const_val ();
  49 }
  50
  51 LONGEST
  52 f77_get_upperbound (struct type *type)
  53 {
  54   if (type->bounds ()->high.kind () == PROP_UNDEFINED)
  55     {
  56       /* We have an assumed size array on our hands.  Assume that
  57          upper_bound == lower_bound so that we show at least 1 element.
  58          If the user wants to see more elements, let him manually ask for 'em
  59          and we'll subscript the array and show him.  */
  60
  61       return f77_get_lowerbound (type);
  62     }
  63
  64   return type->bounds ()->high.const_val ();
  65 }
  66
  67 /* Obtain F77 adjustable array dimensions.  */
  68
  69 static void
  70 f77_get_dynamic_length_of_aggregate (struct type *type)
  71 {
  72   int upper_bound = -1;
  73   int lower_bound = 1;
  74
  75   /* Recursively go all the way down into a possibly multi-dimensional
  76      F77 array and get the bounds.  For simple arrays, this is pretty
  77      easy but when the bounds are dynamic, we must be very careful
  78      to add up all the lengths correctly.  Not doing this right
  79      will lead to horrendous-looking arrays in parameter lists.
  80
  81      This function also works for strings which behave very
  82      similarly to arrays.  */
  83
  84   if (TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_ARRAY
  85       || TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_STRING)
  86     f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
  87
  88   /* Recursion ends here, start setting up lengths.  */
  89   lower_bound = f77_get_lowerbound (type);
  90   upper_bound = f77_get_upperbound (type);
  91
  92   /* Patch in a valid length value.  */
  93
  94   TYPE_LENGTH (type) =
  95     (upper_bound - lower_bound + 1)
  96     * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
  97 }
  98
  99 /* A class used by FORTRAN_PRINT_ARRAY as a specialisation of the array
 100    walking template.  This specialisation prints Fortran arrays.  */
 101
 102 class fortran_array_printer_impl : public fortran_array_walker_base_impl
 103 {
 104 public:
 105   /* Constructor.  TYPE is the array type being printed, ADDRESS is the
 106      address in target memory for the object of TYPE being printed.  VAL is
 107      the GDB value (of TYPE) being printed.  STREAM is where to print to,
 108      RECOURSE is passed through (and prevents infinite recursion), and
 109      OPTIONS are the printing control options.  */
 110   explicit fortran_array_printer_impl (struct type *type,
 111                                        CORE_ADDR address,
 112                                        struct value *val,
 113                                        struct ui_file *stream,
 114                                        int recurse,
 115                                        const struct value_print_options *options)
 116     : m_elts (0),
 117       m_val (val),
 118       m_stream (stream),
 119       m_recurse (recurse),
 120       m_options (options)
 121   { /* Nothing.  */ }
 122
 123   /* Called while iterating over the array bounds.  When SHOULD_CONTINUE is
 124      false then we must return false, as we have reached the end of the
 125      array bounds for this dimension.  However, we also return false if we
 126      have printed too many elements (after printing '...').  In all other
 127      cases, return true.  */
 128   bool continue_walking (bool should_continue)
 129   {
 130     bool cont = should_continue && (m_elts < m_options->print_max);
 131     if (!cont && should_continue)
 132       fputs_filtered ("...", m_stream);
 133     return cont;
 134   }
 135
 136   /* Called when we start iterating over a dimension.  If it's not the
 137      inner most dimension then print an opening '(' character.  */
 138   void start_dimension (bool inner_p)
 139   {
 140     fputs_filtered ("(", m_stream);
 141   }
 142
 143   /* Called when we finish processing a batch of items within a dimension
 144      of the array.  Depending on whether this is the inner most dimension
 145      or not we print different things, but this is all about adding
 146      separators between elements, and dimensions of the array.  */
 147   void finish_dimension (bool inner_p, bool last_p)
 148   {
 149     fputs_filtered (")", m_stream);
 150     if (!last_p)
 151       fputs_filtered (" ", m_stream);
 152   }
 153
 154   /* Called to process an element of ELT_TYPE at offset ELT_OFF from the
 155      start of the parent object.  */
 156   void process_element (struct type *elt_type, LONGEST elt_off, bool last_p)
 157   {
 158     /* Extract the element value from the parent value.  */
 159     struct value *e_val
 160       = value_from_component (m_val, elt_type, elt_off);
 161     common_val_print (e_val, m_stream, m_recurse, m_options, current_language);
 162     if (!last_p)
 163       fputs_filtered (", ", m_stream);
 164     ++m_elts;
 165   }
 166
 167 private:
 168   /* The number of elements printed so far.  */
 169   int m_elts;
 170
 171   /* The value from which we are printing elements.  */
 172   struct value *m_val;
 173
 174   /* The stream we should print too.  */
 175   struct ui_file *m_stream;
 176
 177   /* The recursion counter, passed through when we print each element.  */
 178   int m_recurse;
 179
 180   /* The print control options.  Gives us the maximum number of elements to
 181      print, and is passed through to each element that we print.  */
 182   const struct value_print_options *m_options = nullptr;
 183 };
 184
 185 /* This function gets called to print a Fortran array.  */
 186
 187 static void
 188 fortran_print_array (struct type *type, CORE_ADDR address,
 189                      struct ui_file *stream, int recurse,
 190                      const struct value *val,
 191                      const struct value_print_options *options)
 192 {
 193   fortran_array_walker<fortran_array_printer_impl> p
 194     (type, address, (struct value *) val, stream, recurse, options);
 195   p.walk ();
 196 }
 197 \f
 198
 199 /* Decorations for Fortran.  */
 200
 201 static const struct generic_val_print_decorations f_decorations =
 202 {
 203   "(",
 204   ",",
 205   ")",
 206   ".TRUE.",
 207   ".FALSE.",
 208   "void",
 209   "{",
 210   "}"
 211 };
 212
 213 /* See f-lang.h.  */
 214
 215 void
 216 f_language::value_print_inner (struct value *val, struct ui_file *stream,
 217                                int recurse,
 218                                const struct value_print_options *options) const
 219 {
 220   struct type *type = check_typedef (value_type (val));
 221   struct gdbarch *gdbarch = type->arch ();
 222   int printed_field = 0; /* Number of fields printed.  */
 223   struct type *elttype;
 224   CORE_ADDR addr;
 225   int index;
 226   const gdb_byte *valaddr = value_contents_for_printing (val);
 227   const CORE_ADDR address = value_address (val);
 228
 229   switch (type->code ())
 230     {
 231     case TYPE_CODE_STRING:
 232       f77_get_dynamic_length_of_aggregate (type);
 233       printstr (stream, builtin_type (gdbarch)->builtin_char, valaddr,
 234                 TYPE_LENGTH (type), NULL, 0, options);
 235       break;
 236
 237     case TYPE_CODE_ARRAY:
 238       if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_CHAR)
 239         fortran_print_array (type, address, stream, recurse, val, options);
 240       else
 241         {
 242           struct type *ch_type = TYPE_TARGET_TYPE (type);
 243
 244           f77_get_dynamic_length_of_aggregate (type);
 245           printstr (stream, ch_type, valaddr,
 246                     TYPE_LENGTH (type) / TYPE_LENGTH (ch_type), NULL, 0,
 247                     options);
 248         }
 249       break;
 250
 251     case TYPE_CODE_PTR:
 252       if (options->format && options->format != 's')
 253         {
 254           value_print_scalar_formatted (val, options, 0, stream);
 255           break;
 256         }
 257       else
 258         {
 259           int want_space = 0;
 260
 261           addr = unpack_pointer (type, valaddr);
 262           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 263
 264           if (elttype->code () == TYPE_CODE_FUNC)
 265             {
 266               /* Try to print what function it points to.  */
 267               print_function_pointer_address (options, gdbarch, addr, stream);
 268               return;
 269             }
 270
 271           if (options->symbol_print)
 272             want_space = print_address_demangle (options, gdbarch, addr,
 273                                                  stream, demangle);
 274           else if (options->addressprint && options->format != 's')
 275             {
 276               fputs_filtered (paddress (gdbarch, addr), stream);
 277               want_space = 1;
 278             }
 279
 280           /* For a pointer to char or unsigned char, also print the string
 281              pointed to, unless pointer is null.  */
 282           if (TYPE_LENGTH (elttype) == 1
 283               && elttype->code () == TYPE_CODE_INT
 284               && (options->format == 0 || options->format == 's')
 285               && addr != 0)
 286             {
 287               if (want_space)
 288                 fputs_filtered (" ", stream);
 289               val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
 290                                 stream, options);
 291             }
 292           return;
 293         }
 294       break;
 295
 296     case TYPE_CODE_STRUCT:
 297     case TYPE_CODE_UNION:
 298       /* Starting from the Fortran 90 standard, Fortran supports derived
 299          types.  */
 300       fprintf_filtered (stream, "( ");
 301       for (index = 0; index < type->num_fields (); index++)
 302         {
 303           struct value *field = value_field (val, index);
 304
 305           struct type *field_type = check_typedef (type->field (index).type ());
 306
 307
 308           if (field_type->code () != TYPE_CODE_FUNC)
 309             {
 310               const char *field_name;
 311
 312               if (printed_field > 0)
 313                 fputs_filtered (", ", stream);
 314
 315               field_name = TYPE_FIELD_NAME (type, index);
 316               if (field_name != NULL)
 317                 {
 318                   fputs_styled (field_name, variable_name_style.style (),
 319                                 stream);
 320                   fputs_filtered (" = ", stream);
 321                 }
 322
 323               common_val_print (field, stream, recurse + 1,
 324                                 options, current_language);
 325
 326               ++printed_field;
 327             }
 328          }
 329       fprintf_filtered (stream, " )");
 330       break;
 331
 332     case TYPE_CODE_BOOL:
 333       if (options->format || options->output_format)
 334         {
 335           struct value_print_options opts = *options;
 336           opts.format = (options->format ? options->format
 337                          : options->output_format);
 338           value_print_scalar_formatted (val, &opts, 0, stream);
 339         }
 340       else
 341         {
 342           LONGEST longval = value_as_long (val);
 343           /* The Fortran standard doesn't specify how logical types are
 344              represented.  Different compilers use different non zero
 345              values to represent logical true.  */
 346           if (longval == 0)
 347             fputs_filtered (f_decorations.false_name, stream);
 348           else
 349             fputs_filtered (f_decorations.true_name, stream);
 350         }
 351       break;
 352
 353     case TYPE_CODE_INT:
 354     case TYPE_CODE_REF:
 355     case TYPE_CODE_FUNC:
 356     case TYPE_CODE_FLAGS:
 357     case TYPE_CODE_FLT:
 358     case TYPE_CODE_VOID:
 359     case TYPE_CODE_ERROR:
 360     case TYPE_CODE_RANGE:
 361     case TYPE_CODE_UNDEF:
 362     case TYPE_CODE_COMPLEX:
 363     case TYPE_CODE_CHAR:
 364     default:
 365       generic_value_print (val, stream, recurse, options, &f_decorations);
 366       break;
 367     }
 368 }
 369
 370 static void
 371 info_common_command_for_block (const struct block *block, const char *comname,
 372                                int *any_printed)
 373 {
 374   struct block_iterator iter;
 375   struct symbol *sym;
 376   struct value_print_options opts;
 377
 378   get_user_print_options (&opts);
 379
 380   ALL_BLOCK_SYMBOLS (block, iter, sym)
 381     if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
 382       {
 383         const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
 384         size_t index;
 385
 386         gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
 387
 388         if (comname && (!sym->linkage_name ()
 389                         || strcmp (comname, sym->linkage_name ()) != 0))
 390           continue;
 391
 392         if (*any_printed)
 393           putchar_filtered ('\n');
 394         else
 395           *any_printed = 1;
 396         if (sym->print_name ())
 397           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 398                            sym->print_name ());
 399         else
 400           printf_filtered (_("Contents of blank COMMON block:\n"));
 401
 402         for (index = 0; index < common->n_entries; index++)
 403           {
 404             struct value *val = NULL;
 405
 406             printf_filtered ("%s = ",
 407                              common->contents[index]->print_name ());
 408
 409             try
 410               {
 411                 val = value_of_variable (common->contents[index], block);
 412                 value_print (val, gdb_stdout, &opts);
 413               }
 414
 415             catch (const gdb_exception_error &except)
 416               {
 417                 fprintf_styled (gdb_stdout, metadata_style.style (),
 418                                 "<error reading variable: %s>",
 419                                 except.what ());
 420               }
 421
 422             putchar_filtered ('\n');
 423           }
 424       }
 425 }
 426
 427 /* This function is used to print out the values in a given COMMON
 428    block.  It will always use the most local common block of the
 429    given name.  */
 430
 431 static void
 432 info_common_command (const char *comname, int from_tty)
 433 {
 434   struct frame_info *fi;
 435   const struct block *block;
 436   int values_printed = 0;
 437
 438   /* We have been told to display the contents of F77 COMMON
 439      block supposedly visible in this function.  Let us
 440      first make sure that it is visible and if so, let
 441      us display its contents.  */
 442
 443   fi = get_selected_frame (_("No frame selected"));
 444
 445   /* The following is generally ripped off from stack.c's routine
 446      print_frame_info().  */
 447
 448   block = get_frame_block (fi, 0);
 449   if (block == NULL)
 450     {
 451       printf_filtered (_("No symbol table info available.\n"));
 452       return;
 453     }
 454
 455   while (block)
 456     {
 457       info_common_command_for_block (block, comname, &values_printed);
 458       /* After handling the function's top-level block, stop.  Don't
 459          continue to its superblock, the block of per-file symbols.  */
 460       if (BLOCK_FUNCTION (block))
 461         break;
 462       block = BLOCK_SUPERBLOCK (block);
 463     }
 464
 465   if (!values_printed)
 466     {
 467       if (comname)
 468         printf_filtered (_("No common block '%s'.\n"), comname);
 469       else
 470         printf_filtered (_("No common blocks.\n"));
 471     }
 472 }
 473
 474 void _initialize_f_valprint ();
 475 void
 476 _initialize_f_valprint ()
 477 {
 478   add_info ("common", info_common_command,
 479             _("Print out the values contained in a Fortran COMMON block."));
 480 }