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 static const char *f_extensions[] =
 312 {
 313   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 314   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 315   NULL
 316 };
 317
 318 /* Expression processing for Fortran.  */
 319 static const struct exp_descriptor exp_descriptor_f =
 320 {
 321   print_subexp_standard,
 322   operator_length_standard,
 323   operator_check_standard,
 324   op_name_standard,
 325   dump_subexp_body_standard,
 326   evaluate_subexp_f
 327 };
 328
 329 extern const struct language_defn f_language_defn =
 330 {
 331   "fortran",
 332   "Fortran",
 333   language_fortran,
 334   range_check_on,
 335   case_sensitive_off,
 336   array_column_major,
 337   macro_expansion_no,
 338   f_extensions,
 339   &exp_descriptor_f,
 340   f_parse,                      /* parser */
 341   null_post_parser,
 342   f_printchar,                  /* Print character constant */
 343   f_printstr,                   /* function to print string constant */
 344   f_emit_char,                  /* Function to print a single character */
 345   f_print_type,                 /* Print a type using appropriate syntax */
 346   default_print_typedef,        /* Print a typedef using appropriate syntax */
 347   f_val_print,                  /* Print a value using appropriate syntax */
 348   c_value_print,                /* FIXME */
 349   default_read_var_value,       /* la_read_var_value */
 350   NULL,                         /* Language specific skip_trampoline */
 351   NULL,                         /* name_of_this */
 352   false,                        /* la_store_sym_names_in_linkage_form_p */
 353   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 354   basic_lookup_transparent_type,/* lookup_transparent_type */
 355
 356   /* We could support demangling here to provide module namespaces
 357      also for inferiors with only minimal symbol table (ELF symbols).
 358      Just the mangling standard is not standardized across compilers
 359      and there is no DW_AT_producer available for inferiors with only
 360      the ELF symbols to check the mangling kind.  */
 361   NULL,                         /* Language specific symbol demangler */
 362   NULL,
 363   NULL,                         /* Language specific
 364                                    class_name_from_physname */
 365   f_op_print_tab,               /* expression operators for printing */
 366   0,                            /* arrays are first-class (not c-style) */
 367   1,                            /* String lower bound */
 368   f_word_break_characters,
 369   f_collect_symbol_completion_matches,
 370   f_language_arch_info,
 371   default_print_array_index,
 372   default_pass_by_reference,
 373   default_get_string,
 374   c_watch_location_expression,
 375   NULL,                         /* la_get_symbol_name_matcher */
 376   iterate_over_symbols,
 377   default_search_name_hash,
 378   &default_varobj_ops,
 379   NULL,
 380   NULL
 381 };
 382
 383 static void *
 384 build_fortran_types (struct gdbarch *gdbarch)
 385 {
 386   struct builtin_f_type *builtin_f_type
 387     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 388
 389   builtin_f_type->builtin_void
 390     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");
 391
 392   builtin_f_type->builtin_character
 393     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 394
 395   builtin_f_type->builtin_logical_s1
 396     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 397
 398   builtin_f_type->builtin_integer_s2
 399     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 400                          "integer*2");
 401
 402   builtin_f_type->builtin_integer_s8
 403     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 404                          "integer*8");
 405
 406   builtin_f_type->builtin_logical_s2
 407     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 408                          "logical*2");
 409
 410   builtin_f_type->builtin_logical_s8
 411     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 412                          "logical*8");
 413
 414   builtin_f_type->builtin_integer
 415     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 416                          "integer");
 417
 418   builtin_f_type->builtin_logical
 419     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 420                          "logical*4");
 421
 422   builtin_f_type->builtin_real
 423     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 424                        "real", gdbarch_float_format (gdbarch));
 425   builtin_f_type->builtin_real_s8
 426     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 427                        "real*8", gdbarch_double_format (gdbarch));
 428   builtin_f_type->builtin_real_s16
 429     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 430                        "real*16", gdbarch_long_double_format (gdbarch));
 431
 432   builtin_f_type->builtin_complex_s8
 433     = arch_complex_type (gdbarch, "complex*8",
 434                          builtin_f_type->builtin_real);
 435   builtin_f_type->builtin_complex_s16
 436     = arch_complex_type (gdbarch, "complex*16",
 437                          builtin_f_type->builtin_real_s8);
 438   builtin_f_type->builtin_complex_s32
 439     = arch_complex_type (gdbarch, "complex*32",
 440                          builtin_f_type->builtin_real_s16);
 441
 442   return builtin_f_type;
 443 }
 444
 445 static struct gdbarch_data *f_type_data;
 446
 447 const struct builtin_f_type *
 448 builtin_f_type (struct gdbarch *gdbarch)
 449 {
 450   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 451 }
 452
 453 void
 454 _initialize_f_language (void)
 455 {
 456   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 457 }
 458
 459 /* See f-lang.h.  */
 460
 461 struct value *
 462 fortran_argument_convert (struct value *value, bool is_artificial)
 463 {
 464   if (!is_artificial)
 465     {
 466       /* If the value is not in the inferior e.g. registers values,
 467          convenience variables and user input.  */
 468       if (VALUE_LVAL (value) != lval_memory)
 469         {
 470           struct type *type = value_type (value);
 471           const int length = TYPE_LENGTH (type);
 472           const CORE_ADDR addr
 473             = value_as_long (value_allocate_space_in_inferior (length));
 474           write_memory (addr, value_contents (value), length);
 475           struct value *val
 476             = value_from_contents_and_address (type, value_contents (value),
 477                                                addr);
 478           return value_addr (val);
 479         }
 480       else
 481         return value_addr (value); /* Program variables, e.g. arrays.  */
 482     }
 483     return value;
 484 }
 485
 486 /* See f-lang.h.  */
 487
 488 struct type *
 489 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 490 {
 491   if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
 492     return value_type (arg);
 493   return type;
 494 }