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 #include "target-float.h"
  38
  39 #include <math.h>
  40
  41 /* Local functions */
  42
  43 static void f_printchar (int c, struct type *type, struct ui_file * stream);
  44 static void f_emit_char (int c, struct type *type,
  45                          struct ui_file * stream, int quoter);
  46
  47 /* Return the encoding that should be used for the character type
  48    TYPE.  */
  49
  50 static const char *
  51 f_get_encoding (struct type *type)
  52 {
  53   const char *encoding;
  54
  55   switch (TYPE_LENGTH (type))
  56     {
  57     case 1:
  58       encoding = target_charset (get_type_arch (type));
  59       break;
  60     case 4:
  61       if (gdbarch_byte_order (get_type_arch (type)) == BFD_ENDIAN_BIG)
  62         encoding = "UTF-32BE";
  63       else
  64         encoding = "UTF-32LE";
  65       break;
  66
  67     default:
  68       error (_("unrecognized character type"));
  69     }
  70
  71   return encoding;
  72 }
  73
  74 /* Print the character C on STREAM as part of the contents of a literal
  75    string whose delimiter is QUOTER.  Note that that format for printing
  76    characters and strings is language specific.
  77    FIXME:  This is a copy of the same function from c-exp.y.  It should
  78    be replaced with a true F77 version.  */
  79
  80 static void
  81 f_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
  82 {
  83   const char *encoding = f_get_encoding (type);
  84
  85   generic_emit_char (c, type, stream, quoter, encoding);
  86 }
  87
  88 /* Implementation of la_printchar.  */
  89
  90 static void
  91 f_printchar (int c, struct type *type, struct ui_file *stream)
  92 {
  93   fputs_filtered ("'", stream);
  94   LA_EMIT_CHAR (c, type, stream, '\'');
  95   fputs_filtered ("'", stream);
  96 }
  97
  98 /* Print the character string STRING, printing at most LENGTH characters.
  99    Printing stops early if the number hits print_max; repeat counts
 100    are printed as appropriate.  Print ellipses at the end if we
 101    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
 102    FIXME:  This is a copy of the same function from c-exp.y.  It should
 103    be replaced with a true F77 version.  */
 104
 105 static void
 106 f_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
 107             unsigned int length, const char *encoding, int force_ellipses,
 108             const struct value_print_options *options)
 109 {
 110   const char *type_encoding = f_get_encoding (type);
 111
 112   if (TYPE_LENGTH (type) == 4)
 113     fputs_filtered ("4_", stream);
 114
 115   if (!encoding || !*encoding)
 116     encoding = type_encoding;
 117
 118   generic_printstr (stream, type, string, length, encoding,
 119                     force_ellipses, '\'', 0, options);
 120 }
 121 \f
 122
 123 /* Table of operators and their precedences for printing expressions.  */
 124
 125 static const struct op_print f_op_print_tab[] =
 126 {
 127   {"+", BINOP_ADD, PREC_ADD, 0},
 128   {"+", UNOP_PLUS, PREC_PREFIX, 0},
 129   {"-", BINOP_SUB, PREC_ADD, 0},
 130   {"-", UNOP_NEG, PREC_PREFIX, 0},
 131   {"*", BINOP_MUL, PREC_MUL, 0},
 132   {"/", BINOP_DIV, PREC_MUL, 0},
 133   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
 134   {"MOD", BINOP_REM, PREC_MUL, 0},
 135   {"=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 136   {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 137   {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 138   {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 139   {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0},
 140   {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 141   {".LE.", BINOP_LEQ, PREC_ORDER, 0},
 142   {".GE.", BINOP_GEQ, PREC_ORDER, 0},
 143   {".GT.", BINOP_GTR, PREC_ORDER, 0},
 144   {".LT.", BINOP_LESS, PREC_ORDER, 0},
 145   {"**", UNOP_IND, PREC_PREFIX, 0},
 146   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 147   {NULL, OP_NULL, PREC_REPEAT, 0}
 148 };
 149 \f
 150 enum f_primitive_types {
 151   f_primitive_type_character,
 152   f_primitive_type_logical,
 153   f_primitive_type_logical_s1,
 154   f_primitive_type_logical_s2,
 155   f_primitive_type_logical_s8,
 156   f_primitive_type_integer,
 157   f_primitive_type_integer_s2,
 158   f_primitive_type_real,
 159   f_primitive_type_real_s8,
 160   f_primitive_type_real_s16,
 161   f_primitive_type_complex_s8,
 162   f_primitive_type_complex_s16,
 163   f_primitive_type_void,
 164   nr_f_primitive_types
 165 };
 166
 167 static void
 168 f_language_arch_info (struct gdbarch *gdbarch,
 169                       struct language_arch_info *lai)
 170 {
 171   const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
 172
 173   lai->string_char_type = builtin->builtin_character;
 174   lai->primitive_type_vector
 175     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
 176                               struct type *);
 177
 178   lai->primitive_type_vector [f_primitive_type_character]
 179     = builtin->builtin_character;
 180   lai->primitive_type_vector [f_primitive_type_logical]
 181     = builtin->builtin_logical;
 182   lai->primitive_type_vector [f_primitive_type_logical_s1]
 183     = builtin->builtin_logical_s1;
 184   lai->primitive_type_vector [f_primitive_type_logical_s2]
 185     = builtin->builtin_logical_s2;
 186   lai->primitive_type_vector [f_primitive_type_logical_s8]
 187     = builtin->builtin_logical_s8;
 188   lai->primitive_type_vector [f_primitive_type_real]
 189     = builtin->builtin_real;
 190   lai->primitive_type_vector [f_primitive_type_real_s8]
 191     = builtin->builtin_real_s8;
 192   lai->primitive_type_vector [f_primitive_type_real_s16]
 193     = builtin->builtin_real_s16;
 194   lai->primitive_type_vector [f_primitive_type_complex_s8]
 195     = builtin->builtin_complex_s8;
 196   lai->primitive_type_vector [f_primitive_type_complex_s16]
 197     = builtin->builtin_complex_s16;
 198   lai->primitive_type_vector [f_primitive_type_void]
 199     = builtin->builtin_void;
 200
 201   lai->bool_type_symbol = "logical";
 202   lai->bool_type_default = builtin->builtin_logical_s2;
 203 }
 204
 205 /* Remove the modules separator :: from the default break list.  */
 206
 207 static const char *
 208 f_word_break_characters (void)
 209 {
 210   static char *retval;
 211
 212   if (!retval)
 213     {
 214       char *s;
 215
 216       retval = xstrdup (default_word_break_characters ());
 217       s = strchr (retval, ':');
 218       if (s)
 219         {
 220           char *last_char = &s[strlen (s) - 1];
 221
 222           *s = *last_char;
 223           *last_char = 0;
 224         }
 225     }
 226   return retval;
 227 }
 228
 229 /* Consider the modules separator :: as a valid symbol name character
 230    class.  */
 231
 232 static void
 233 f_collect_symbol_completion_matches (completion_tracker &tracker,
 234                                      complete_symbol_mode mode,
 235                                      symbol_name_match_type compare_name,
 236                                      const char *text, const char *word,
 237                                      enum type_code code)
 238 {
 239   default_collect_symbol_completion_matches_break_on (tracker, mode,
 240                                                       compare_name,
 241                                                       text, word, ":", code);
 242 }
 243
 244 /* Special expression evaluation cases for Fortran.  */
 245 struct value *
 246 evaluate_subexp_f (struct type *expect_type, struct expression *exp,
 247                    int *pos, enum noside noside)
 248 {
 249   struct value *arg1 = NULL;
 250   enum exp_opcode op;
 251   int pc;
 252   struct type *type;
 253
 254   pc = *pos;
 255   *pos += 1;
 256   op = exp->elts[pc].opcode;
 257
 258   switch (op)
 259     {
 260     default:
 261       *pos -= 1;
 262       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 263
 264     case UNOP_ABS:
 265       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 266       if (noside == EVAL_SKIP)
 267         return eval_skip_value (exp);
 268       type = value_type (arg1);
 269       switch (TYPE_CODE (type))
 270         {
 271         case TYPE_CODE_FLT:
 272           {
 273             double d
 274               = fabs (target_float_to_host_double (value_contents (arg1),
 275                                                    value_type (arg1)));
 276             return value_from_host_double (type, d);
 277           }
 278         case TYPE_CODE_INT:
 279           {
 280             LONGEST l = value_as_long (arg1);
 281             l = llabs (l);
 282             return value_from_longest (type, l);
 283           }
 284         }
 285       error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
 286
 287     case UNOP_KIND:
 288       arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
 289       type = value_type (arg1);
 290
 291       switch (TYPE_CODE (type))
 292         {
 293           case TYPE_CODE_STRUCT:
 294           case TYPE_CODE_UNION:
 295           case TYPE_CODE_MODULE:
 296           case TYPE_CODE_FUNC:
 297             error (_("argument to kind must be an intrinsic type"));
 298         }
 299
 300       if (!TYPE_TARGET_TYPE (type))
 301         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 302                                    TYPE_LENGTH (type));
 303       return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 304                                  TYPE_LENGTH (TYPE_TARGET_TYPE(type)));
 305     }
 306
 307   /* Should be unreachable.  */
 308   return nullptr;
 309 }
 310
 311 /* Return true if TYPE is a string.  */
 312
 313 static bool
 314 f_is_string_type_p (struct type *type)
 315 {
 316   type = check_typedef (type);
 317   return (TYPE_CODE (type) == TYPE_CODE_STRING
 318           || (TYPE_CODE (type) == TYPE_CODE_ARRAY
 319               && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_CHAR));
 320 }
 321
 322 static const char *f_extensions[] =
 323 {
 324   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 325   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 326   NULL
 327 };
 328
 329 /* Expression processing for Fortran.  */
 330 static const struct exp_descriptor exp_descriptor_f =
 331 {
 332   print_subexp_standard,
 333   operator_length_standard,
 334   operator_check_standard,
 335   op_name_standard,
 336   dump_subexp_body_standard,
 337   evaluate_subexp_f
 338 };
 339
 340 extern const struct language_defn f_language_defn =
 341 {
 342   "fortran",
 343   "Fortran",
 344   language_fortran,
 345   range_check_on,
 346   case_sensitive_off,
 347   array_column_major,
 348   macro_expansion_no,
 349   f_extensions,
 350   &exp_descriptor_f,
 351   f_parse,                      /* parser */
 352   null_post_parser,
 353   f_printchar,                  /* Print character constant */
 354   f_printstr,                   /* function to print string constant */
 355   f_emit_char,                  /* Function to print a single character */
 356   f_print_type,                 /* Print a type using appropriate syntax */
 357   default_print_typedef,        /* Print a typedef using appropriate syntax */
 358   f_val_print,                  /* Print a value using appropriate syntax */
 359   c_value_print,                /* FIXME */
 360   default_read_var_value,       /* la_read_var_value */
 361   NULL,                         /* Language specific skip_trampoline */
 362   NULL,                         /* name_of_this */
 363   false,                        /* la_store_sym_names_in_linkage_form_p */
 364   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 365   basic_lookup_transparent_type,/* lookup_transparent_type */
 366
 367   /* We could support demangling here to provide module namespaces
 368      also for inferiors with only minimal symbol table (ELF symbols).
 369      Just the mangling standard is not standardized across compilers
 370      and there is no DW_AT_producer available for inferiors with only
 371      the ELF symbols to check the mangling kind.  */
 372   NULL,                         /* Language specific symbol demangler */
 373   NULL,
 374   NULL,                         /* Language specific
 375                                    class_name_from_physname */
 376   f_op_print_tab,               /* expression operators for printing */
 377   0,                            /* arrays are first-class (not c-style) */
 378   1,                            /* String lower bound */
 379   f_word_break_characters,
 380   f_collect_symbol_completion_matches,
 381   f_language_arch_info,
 382   default_print_array_index,
 383   default_pass_by_reference,
 384   default_get_string,
 385   c_watch_location_expression,
 386   NULL,                         /* la_get_symbol_name_matcher */
 387   iterate_over_symbols,
 388   default_search_name_hash,
 389   &default_varobj_ops,
 390   NULL,
 391   NULL,
 392   f_is_string_type_p,
 393   "(...)"                       /* la_struct_too_deep_ellipsis */
 394 };
 395
 396 static void *
 397 build_fortran_types (struct gdbarch *gdbarch)
 398 {
 399   struct builtin_f_type *builtin_f_type
 400     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 401
 402   builtin_f_type->builtin_void
 403     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");
 404
 405   builtin_f_type->builtin_character
 406     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 407
 408   builtin_f_type->builtin_logical_s1
 409     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 410
 411   builtin_f_type->builtin_integer_s2
 412     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 413                          "integer*2");
 414
 415   builtin_f_type->builtin_integer_s8
 416     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 417                          "integer*8");
 418
 419   builtin_f_type->builtin_logical_s2
 420     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 421                          "logical*2");
 422
 423   builtin_f_type->builtin_logical_s8
 424     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 425                          "logical*8");
 426
 427   builtin_f_type->builtin_integer
 428     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 429                          "integer");
 430
 431   builtin_f_type->builtin_logical
 432     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 433                          "logical*4");
 434
 435   builtin_f_type->builtin_real
 436     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 437                        "real", gdbarch_float_format (gdbarch));
 438   builtin_f_type->builtin_real_s8
 439     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 440                        "real*8", gdbarch_double_format (gdbarch));
 441   builtin_f_type->builtin_real_s16
 442     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 443                        "real*16", gdbarch_long_double_format (gdbarch));
 444
 445   builtin_f_type->builtin_complex_s8
 446     = arch_complex_type (gdbarch, "complex*8",
 447                          builtin_f_type->builtin_real);
 448   builtin_f_type->builtin_complex_s16
 449     = arch_complex_type (gdbarch, "complex*16",
 450                          builtin_f_type->builtin_real_s8);
 451   builtin_f_type->builtin_complex_s32
 452     = arch_complex_type (gdbarch, "complex*32",
 453                          builtin_f_type->builtin_real_s16);
 454
 455   return builtin_f_type;
 456 }
 457
 458 static struct gdbarch_data *f_type_data;
 459
 460 const struct builtin_f_type *
 461 builtin_f_type (struct gdbarch *gdbarch)
 462 {
 463   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 464 }
 465
 466 void
 467 _initialize_f_language (void)
 468 {
 469   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 470 }
 471
 472 /* See f-lang.h.  */
 473
 474 struct value *
 475 fortran_argument_convert (struct value *value, bool is_artificial)
 476 {
 477   if (!is_artificial)
 478     {
 479       /* If the value is not in the inferior e.g. registers values,
 480          convenience variables and user input.  */
 481       if (VALUE_LVAL (value) != lval_memory)
 482         {
 483           struct type *type = value_type (value);
 484           const int length = TYPE_LENGTH (type);
 485           const CORE_ADDR addr
 486             = value_as_long (value_allocate_space_in_inferior (length));
 487           write_memory (addr, value_contents (value), length);
 488           struct value *val
 489             = value_from_contents_and_address (type, value_contents (value),
 490                                                addr);
 491           return value_addr (val);
 492         }
 493       else
 494         return value_addr (value); /* Program variables, e.g. arrays.  */
 495     }
 496     return value;
 497 }
 498
 499 /* See f-lang.h.  */
 500
 501 struct type *
 502 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 503 {
 504   if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
 505     return value_type (arg);
 506   return type;
 507 }