gdb/f-lang.c

   1 /* Fortran language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-2019 Free Software Foundation, Inc.
   4
   5    Contributed by Motorola.  Adapted from the C parser by Farooq Butt
   6    (fmbutt@engage.sps.mot.com).
   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 "parser-defs.h"
  28 #include "language.h"
  29 #include "varobj.h"
  30 #include "gdbcore.h"
  31 #include "f-lang.h"
  32 #include "valprint.h"
  33 #include "value.h"
  34 #include "cp-support.h"
  35 #include "charset.h"
  36 #include "c-lang.h"
  37
  38
  39 /* Local functions */
  40
  41 static void f_printchar (int c, struct type *type, struct ui_file * stream);
  42 static void f_emit_char (int c, struct type *type,
  43                          struct ui_file * stream, int quoter);
  44
  45 /* Return the encoding that should be used for the character type
  46    TYPE.  */
  47
  48 static const char *
  49 f_get_encoding (struct type *type)
  50 {
  51   const char *encoding;
  52
  53   switch (TYPE_LENGTH (type))
  54     {
  55     case 1:
  56       encoding = target_charset (get_type_arch (type));
  57       break;
  58     case 4:
  59       if (gdbarch_byte_order (get_type_arch (type)) == BFD_ENDIAN_BIG)
  60         encoding = "UTF-32BE";
  61       else
  62         encoding = "UTF-32LE";
  63       break;
  64
  65     default:
  66       error (_("unrecognized character type"));
  67     }
  68
  69   return encoding;
  70 }
  71
  72 /* Print the character C on STREAM as part of the contents of a literal
  73    string whose delimiter is QUOTER.  Note that that format for printing
  74    characters and strings is language specific.
  75    FIXME:  This is a copy of the same function from c-exp.y.  It should
  76    be replaced with a true F77 version.  */
  77
  78 static void
  79 f_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
  80 {
  81   const char *encoding = f_get_encoding (type);
  82
  83   generic_emit_char (c, type, stream, quoter, encoding);
  84 }
  85
  86 /* Implementation of la_printchar.  */
  87
  88 static void
  89 f_printchar (int c, struct type *type, struct ui_file *stream)
  90 {
  91   fputs_filtered ("'", stream);
  92   LA_EMIT_CHAR (c, type, stream, '\'');
  93   fputs_filtered ("'", stream);
  94 }
  95
  96 /* Print the character string STRING, printing at most LENGTH characters.
  97    Printing stops early if the number hits print_max; repeat counts
  98    are printed as appropriate.  Print ellipses at the end if we
  99    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
 100    FIXME:  This is a copy of the same function from c-exp.y.  It should
 101    be replaced with a true F77 version.  */
 102
 103 static void
 104 f_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
 105             unsigned int length, const char *encoding, int force_ellipses,
 106             const struct value_print_options *options)
 107 {
 108   const char *type_encoding = f_get_encoding (type);
 109
 110   if (TYPE_LENGTH (type) == 4)
 111     fputs_filtered ("4_", stream);
 112
 113   if (!encoding || !*encoding)
 114     encoding = type_encoding;
 115
 116   generic_printstr (stream, type, string, length, encoding,
 117                     force_ellipses, '\'', 0, options);
 118 }
 119 \f
 120
 121 /* Table of operators and their precedences for printing expressions.  */
 122
 123 static const struct op_print f_op_print_tab[] =
 124 {
 125   {"+", BINOP_ADD, PREC_ADD, 0},
 126   {"+", UNOP_PLUS, PREC_PREFIX, 0},
 127   {"-", BINOP_SUB, PREC_ADD, 0},
 128   {"-", UNOP_NEG, PREC_PREFIX, 0},
 129   {"*", BINOP_MUL, PREC_MUL, 0},
 130   {"/", BINOP_DIV, PREC_MUL, 0},
 131   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
 132   {"MOD", BINOP_REM, PREC_MUL, 0},
 133   {"=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 134   {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 135   {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 136   {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 137   {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0},
 138   {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 139   {".LE.", BINOP_LEQ, PREC_ORDER, 0},
 140   {".GE.", BINOP_GEQ, PREC_ORDER, 0},
 141   {".GT.", BINOP_GTR, PREC_ORDER, 0},
 142   {".LT.", BINOP_LESS, PREC_ORDER, 0},
 143   {"**", UNOP_IND, PREC_PREFIX, 0},
 144   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 145   {NULL, OP_NULL, PREC_REPEAT, 0}
 146 };
 147 \f
 148 enum f_primitive_types {
 149   f_primitive_type_character,
 150   f_primitive_type_logical,
 151   f_primitive_type_logical_s1,
 152   f_primitive_type_logical_s2,
 153   f_primitive_type_logical_s8,
 154   f_primitive_type_integer,
 155   f_primitive_type_integer_s2,
 156   f_primitive_type_real,
 157   f_primitive_type_real_s8,
 158   f_primitive_type_real_s16,
 159   f_primitive_type_complex_s8,
 160   f_primitive_type_complex_s16,
 161   f_primitive_type_void,
 162   nr_f_primitive_types
 163 };
 164
 165 static void
 166 f_language_arch_info (struct gdbarch *gdbarch,
 167                       struct language_arch_info *lai)
 168 {
 169   const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
 170
 171   lai->string_char_type = builtin->builtin_character;
 172   lai->primitive_type_vector
 173     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
 174                               struct type *);
 175
 176   lai->primitive_type_vector [f_primitive_type_character]
 177     = builtin->builtin_character;
 178   lai->primitive_type_vector [f_primitive_type_logical]
 179     = builtin->builtin_logical;
 180   lai->primitive_type_vector [f_primitive_type_logical_s1]
 181     = builtin->builtin_logical_s1;
 182   lai->primitive_type_vector [f_primitive_type_logical_s2]
 183     = builtin->builtin_logical_s2;
 184   lai->primitive_type_vector [f_primitive_type_logical_s8]
 185     = builtin->builtin_logical_s8;
 186   lai->primitive_type_vector [f_primitive_type_real]
 187     = builtin->builtin_real;
 188   lai->primitive_type_vector [f_primitive_type_real_s8]
 189     = builtin->builtin_real_s8;
 190   lai->primitive_type_vector [f_primitive_type_real_s16]
 191     = builtin->builtin_real_s16;
 192   lai->primitive_type_vector [f_primitive_type_complex_s8]
 193     = builtin->builtin_complex_s8;
 194   lai->primitive_type_vector [f_primitive_type_complex_s16]
 195     = builtin->builtin_complex_s16;
 196   lai->primitive_type_vector [f_primitive_type_void]
 197     = builtin->builtin_void;
 198
 199   lai->bool_type_symbol = "logical";
 200   lai->bool_type_default = builtin->builtin_logical_s2;
 201 }
 202
 203 /* Remove the modules separator :: from the default break list.  */
 204
 205 static const char *
 206 f_word_break_characters (void)
 207 {
 208   static char *retval;
 209
 210   if (!retval)
 211     {
 212       char *s;
 213
 214       retval = xstrdup (default_word_break_characters ());
 215       s = strchr (retval, ':');
 216       if (s)
 217         {
 218           char *last_char = &s[strlen (s) - 1];
 219
 220           *s = *last_char;
 221           *last_char = 0;
 222         }
 223     }
 224   return retval;
 225 }
 226
 227 /* Consider the modules separator :: as a valid symbol name character
 228    class.  */
 229
 230 static void
 231 f_collect_symbol_completion_matches (completion_tracker &tracker,
 232                                      complete_symbol_mode mode,
 233                                      symbol_name_match_type compare_name,
 234                                      const char *text, const char *word,
 235                                      enum type_code code)
 236 {
 237   default_collect_symbol_completion_matches_break_on (tracker, mode,
 238                                                       compare_name,
 239                                                       text, word, ":", code);
 240 }
 241
 242 static const char *f_extensions[] =
 243 {
 244   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 245   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 246   NULL
 247 };
 248
 249 extern const struct language_defn f_language_defn =
 250 {
 251   "fortran",
 252   "Fortran",
 253   language_fortran,
 254   range_check_on,
 255   case_sensitive_off,
 256   array_column_major,
 257   macro_expansion_no,
 258   f_extensions,
 259   &exp_descriptor_standard,
 260   f_parse,                      /* parser */
 261   null_post_parser,
 262   f_printchar,                  /* Print character constant */
 263   f_printstr,                   /* function to print string constant */
 264   f_emit_char,                  /* Function to print a single character */
 265   f_print_type,                 /* Print a type using appropriate syntax */
 266   default_print_typedef,        /* Print a typedef using appropriate syntax */
 267   f_val_print,                  /* Print a value using appropriate syntax */
 268   c_value_print,                /* FIXME */
 269   default_read_var_value,       /* la_read_var_value */
 270   NULL,                         /* Language specific skip_trampoline */
 271   NULL,                         /* name_of_this */
 272   false,                        /* la_store_sym_names_in_linkage_form_p */
 273   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 274   basic_lookup_transparent_type,/* lookup_transparent_type */
 275
 276   /* We could support demangling here to provide module namespaces
 277      also for inferiors with only minimal symbol table (ELF symbols).
 278      Just the mangling standard is not standardized across compilers
 279      and there is no DW_AT_producer available for inferiors with only
 280      the ELF symbols to check the mangling kind.  */
 281   NULL,                         /* Language specific symbol demangler */
 282   NULL,
 283   NULL,                         /* Language specific
 284                                    class_name_from_physname */
 285   f_op_print_tab,               /* expression operators for printing */
 286   0,                            /* arrays are first-class (not c-style) */
 287   1,                            /* String lower bound */
 288   f_word_break_characters,
 289   f_collect_symbol_completion_matches,
 290   f_language_arch_info,
 291   default_print_array_index,
 292   default_pass_by_reference,
 293   default_get_string,
 294   c_watch_location_expression,
 295   NULL,                         /* la_get_symbol_name_matcher */
 296   iterate_over_symbols,
 297   default_search_name_hash,
 298   &default_varobj_ops,
 299   NULL,
 300   NULL,
 301   LANG_MAGIC
 302 };
 303
 304 static void *
 305 build_fortran_types (struct gdbarch *gdbarch)
 306 {
 307   struct builtin_f_type *builtin_f_type
 308     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 309
 310   builtin_f_type->builtin_void
 311     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");
 312
 313   builtin_f_type->builtin_character
 314     = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
 315
 316   builtin_f_type->builtin_logical_s1
 317     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 318
 319   builtin_f_type->builtin_integer_s2
 320     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 321                          "integer*2");
 322
 323   builtin_f_type->builtin_logical_s2
 324     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 325                          "logical*2");
 326
 327   builtin_f_type->builtin_logical_s8
 328     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 329                          "logical*8");
 330
 331   builtin_f_type->builtin_integer
 332     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 333                          "integer");
 334
 335   builtin_f_type->builtin_logical
 336     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 337                          "logical*4");
 338
 339   builtin_f_type->builtin_real
 340     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 341                        "real", gdbarch_float_format (gdbarch));
 342   builtin_f_type->builtin_real_s8
 343     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 344                        "real*8", gdbarch_double_format (gdbarch));
 345   builtin_f_type->builtin_real_s16
 346     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 347                        "real*16", gdbarch_long_double_format (gdbarch));
 348
 349   builtin_f_type->builtin_complex_s8
 350     = arch_complex_type (gdbarch, "complex*8",
 351                          builtin_f_type->builtin_real);
 352   builtin_f_type->builtin_complex_s16
 353     = arch_complex_type (gdbarch, "complex*16",
 354                          builtin_f_type->builtin_real_s8);
 355   builtin_f_type->builtin_complex_s32
 356     = arch_complex_type (gdbarch, "complex*32",
 357                          builtin_f_type->builtin_real_s16);
 358
 359   return builtin_f_type;
 360 }
 361
 362 static struct gdbarch_data *f_type_data;
 363
 364 const struct builtin_f_type *
 365 builtin_f_type (struct gdbarch *gdbarch)
 366 {
 367   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 368 }
 369
 370 void
 371 _initialize_f_language (void)
 372 {
 373   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 374 }
 375
 376 /* See f-lang.h.  */
 377
 378 struct value *
 379 fortran_argument_convert (struct value *value, bool is_artificial)
 380 {
 381   if (!is_artificial)
 382     {
 383       /* If the value is not in the inferior e.g. registers values,
 384          convenience variables and user input.  */
 385       if (VALUE_LVAL (value) != lval_memory)
 386         {
 387           struct type *type = value_type (value);
 388           const int length = TYPE_LENGTH (type);
 389           const CORE_ADDR addr
 390             = value_as_long (value_allocate_space_in_inferior (length));
 391           write_memory (addr, value_contents (value), length);
 392           struct value *val
 393             = value_from_contents_and_address (type, value_contents (value),
 394                                                addr);
 395           return value_addr (val);
 396         }
 397       else
 398         return value_addr (value); /* Program variables, e.g. arrays.  */
 399     }
 400     return value;
 401 }
 402
 403 /* See f-lang.h.  */
 404
 405 struct type *
 406 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 407 {
 408   if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
 409     return value_type (arg);
 410   return type;
 411 }