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