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