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 /* Special expression evaluation cases for Fortran.  */
 243 struct value *
 244 evaluate_subexp_f (struct type *expect_type, struct expression *exp,
 245                    int *pos, enum noside noside)
 246 {
 247   struct value *arg1 = NULL;
 248   enum exp_opcode op;
 249   int pc;
 250   struct type *type;
 251
 252   pc = *pos;
 253   *pos += 1;
 254   op = exp->elts[pc].opcode;
 255
 256   switch (op)
 257     {
 258     default:
 259       *pos -= 1;
 260       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 261
 262     case UNOP_KIND:
 263       arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
 264       type = value_type (arg1);
 265
 266       switch (TYPE_CODE (type))
 267         {
 268           case TYPE_CODE_STRUCT:
 269           case TYPE_CODE_UNION:
 270           case TYPE_CODE_MODULE:
 271           case TYPE_CODE_FUNC:
 272             error (_("argument to kind must be an intrinsic type"));
 273         }
 274
 275       if (!TYPE_TARGET_TYPE (type))
 276         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 277                                    TYPE_LENGTH (type));
 278       return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 279                                  TYPE_LENGTH (TYPE_TARGET_TYPE(type)));
 280     }
 281
 282   /* Should be unreachable.  */
 283   return nullptr;
 284 }
 285
 286 static const char *f_extensions[] =
 287 {
 288   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 289   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 290   NULL
 291 };
 292
 293 /* Expression processing for Fortran.  */
 294 static const struct exp_descriptor exp_descriptor_f =
 295 {
 296   print_subexp_standard,
 297   operator_length_standard,
 298   operator_check_standard,
 299   op_name_standard,
 300   dump_subexp_body_standard,
 301   evaluate_subexp_f
 302 };
 303
 304 extern const struct language_defn f_language_defn =
 305 {
 306   "fortran",
 307   "Fortran",
 308   language_fortran,
 309   range_check_on,
 310   case_sensitive_off,
 311   array_column_major,
 312   macro_expansion_no,
 313   f_extensions,
 314   &exp_descriptor_f,
 315   f_parse,                      /* parser */
 316   null_post_parser,
 317   f_printchar,                  /* Print character constant */
 318   f_printstr,                   /* function to print string constant */
 319   f_emit_char,                  /* Function to print a single character */
 320   f_print_type,                 /* Print a type using appropriate syntax */
 321   default_print_typedef,        /* Print a typedef using appropriate syntax */
 322   f_val_print,                  /* Print a value using appropriate syntax */
 323   c_value_print,                /* FIXME */
 324   default_read_var_value,       /* la_read_var_value */
 325   NULL,                         /* Language specific skip_trampoline */
 326   NULL,                         /* name_of_this */
 327   false,                        /* la_store_sym_names_in_linkage_form_p */
 328   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 329   basic_lookup_transparent_type,/* lookup_transparent_type */
 330
 331   /* We could support demangling here to provide module namespaces
 332      also for inferiors with only minimal symbol table (ELF symbols).
 333      Just the mangling standard is not standardized across compilers
 334      and there is no DW_AT_producer available for inferiors with only
 335      the ELF symbols to check the mangling kind.  */
 336   NULL,                         /* Language specific symbol demangler */
 337   NULL,
 338   NULL,                         /* Language specific
 339                                    class_name_from_physname */
 340   f_op_print_tab,               /* expression operators for printing */
 341   0,                            /* arrays are first-class (not c-style) */
 342   1,                            /* String lower bound */
 343   f_word_break_characters,
 344   f_collect_symbol_completion_matches,
 345   f_language_arch_info,
 346   default_print_array_index,
 347   default_pass_by_reference,
 348   default_get_string,
 349   c_watch_location_expression,
 350   NULL,                         /* la_get_symbol_name_matcher */
 351   iterate_over_symbols,
 352   default_search_name_hash,
 353   &default_varobj_ops,
 354   NULL,
 355   NULL,
 356   LANG_MAGIC
 357 };
 358
 359 static void *
 360 build_fortran_types (struct gdbarch *gdbarch)
 361 {
 362   struct builtin_f_type *builtin_f_type
 363     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 364
 365   builtin_f_type->builtin_void
 366     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");
 367
 368   builtin_f_type->builtin_character
 369     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 370
 371   builtin_f_type->builtin_logical_s1
 372     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 373
 374   builtin_f_type->builtin_integer_s2
 375     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 376                          "integer*2");
 377
 378   builtin_f_type->builtin_integer_s8
 379     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 380                          "integer*8");
 381
 382   builtin_f_type->builtin_logical_s2
 383     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 384                          "logical*2");
 385
 386   builtin_f_type->builtin_logical_s8
 387     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 388                          "logical*8");
 389
 390   builtin_f_type->builtin_integer
 391     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 392                          "integer");
 393
 394   builtin_f_type->builtin_logical
 395     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 396                          "logical*4");
 397
 398   builtin_f_type->builtin_real
 399     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 400                        "real", gdbarch_float_format (gdbarch));
 401   builtin_f_type->builtin_real_s8
 402     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 403                        "real*8", gdbarch_double_format (gdbarch));
 404   builtin_f_type->builtin_real_s16
 405     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 406                        "real*16", gdbarch_long_double_format (gdbarch));
 407
 408   builtin_f_type->builtin_complex_s8
 409     = arch_complex_type (gdbarch, "complex*8",
 410                          builtin_f_type->builtin_real);
 411   builtin_f_type->builtin_complex_s16
 412     = arch_complex_type (gdbarch, "complex*16",
 413                          builtin_f_type->builtin_real_s8);
 414   builtin_f_type->builtin_complex_s32
 415     = arch_complex_type (gdbarch, "complex*32",
 416                          builtin_f_type->builtin_real_s16);
 417
 418   return builtin_f_type;
 419 }
 420
 421 static struct gdbarch_data *f_type_data;
 422
 423 const struct builtin_f_type *
 424 builtin_f_type (struct gdbarch *gdbarch)
 425 {
 426   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 427 }
 428
 429 void
 430 _initialize_f_language (void)
 431 {
 432   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 433 }
 434
 435 /* See f-lang.h.  */
 436
 437 struct value *
 438 fortran_argument_convert (struct value *value, bool is_artificial)
 439 {
 440   if (!is_artificial)
 441     {
 442       /* If the value is not in the inferior e.g. registers values,
 443          convenience variables and user input.  */
 444       if (VALUE_LVAL (value) != lval_memory)
 445         {
 446           struct type *type = value_type (value);
 447           const int length = TYPE_LENGTH (type);
 448           const CORE_ADDR addr
 449             = value_as_long (value_allocate_space_in_inferior (length));
 450           write_memory (addr, value_contents (value), length);
 451           struct value *val
 452             = value_from_contents_and_address (type, value_contents (value),
 453                                                addr);
 454           return value_addr (val);
 455         }
 456       else
 457         return value_addr (value); /* Program variables, e.g. arrays.  */
 458     }
 459     return value;
 460 }
 461
 462 /* See f-lang.h.  */
 463
 464 struct type *
 465 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 466 {
 467   if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
 468     return value_type (arg);
 469   return type;
 470 }