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_FORTRAN_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 /* Special expression lengths for Fortran.  */
 323
 324 static void
 325 operator_length_f (const struct expression *exp, int pc, int *oplenp,
 326                    int *argsp)
 327 {
 328   int oplen = 1;
 329   int args = 0;
 330
 331   switch (exp->elts[pc - 1].opcode)
 332     {
 333     default:
 334       operator_length_standard (exp, pc, oplenp, argsp);
 335       return;
 336
 337     case UNOP_FORTRAN_KIND:
 338       oplen = 1;
 339       args = 1;
 340       break;
 341     }
 342
 343   *oplenp = oplen;
 344   *argsp = args;
 345 }
 346
 347 /* Special expression printing for Fortran.  */
 348
 349 static void
 350 print_subexp_f (struct expression *exp, int *pos,
 351                 struct ui_file *stream, enum precedence prec)
 352 {
 353   int pc = *pos;
 354   enum exp_opcode op = exp->elts[pc].opcode;
 355
 356   switch (op)
 357     {
 358     default:
 359       print_subexp_standard (exp, pos, stream, prec);
 360       return;
 361
 362     case UNOP_FORTRAN_KIND:
 363       (*pos)++;
 364       fputs_filtered ("KIND(", stream);
 365       print_subexp (exp, pos, stream, PREC_SUFFIX);
 366       fputs_filtered (")", stream);
 367       return;
 368     }
 369 }
 370
 371 /* Special expression names for Fortran.  */
 372
 373 static const char *
 374 op_name_f (enum exp_opcode opcode)
 375 {
 376   switch (opcode)
 377     {
 378     default:
 379       return op_name_standard (opcode);
 380
 381 #define OP(name)        \
 382     case name:          \
 383       return #name ;
 384 #include "fortran-operator.def"
 385 #undef OP
 386     }
 387 }
 388
 389 /* Special expression dumping for Fortran.  */
 390
 391 static int
 392 dump_subexp_body_f (struct expression *exp,
 393                     struct ui_file *stream, int elt)
 394 {
 395   int opcode = exp->elts[elt].opcode;
 396   int oplen, nargs, i;
 397
 398   switch (opcode)
 399     {
 400     default:
 401       return dump_subexp_body_standard (exp, stream, elt);
 402
 403     case UNOP_FORTRAN_KIND:
 404       operator_length_f (exp, (elt + 1), &oplen, &nargs);
 405       break;
 406     }
 407
 408   elt += oplen;
 409   for (i = 0; i < nargs; i += 1)
 410     elt = dump_subexp (exp, stream, elt);
 411
 412   return elt;
 413 }
 414
 415 /* Special expression checking for Fortran.  */
 416
 417 static int
 418 operator_check_f (struct expression *exp, int pos,
 419                   int (*objfile_func) (struct objfile *objfile,
 420                                        void *data),
 421                   void *data)
 422 {
 423   const union exp_element *const elts = exp->elts;
 424
 425   switch (elts[pos].opcode)
 426     {
 427     case UNOP_FORTRAN_KIND:
 428       /* Any references to objfiles are held in the arguments to this
 429          expression, not within the expression itself, so no additional
 430          checking is required here, the outer expression iteration code
 431          will take care of checking each argument.  */
 432       break;
 433
 434     default:
 435       return operator_check_standard (exp, pos, objfile_func, data);
 436     }
 437
 438   return 0;
 439 }
 440
 441 static const char *f_extensions[] =
 442 {
 443   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 444   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 445   NULL
 446 };
 447
 448 /* Expression processing for Fortran.  */
 449 static const struct exp_descriptor exp_descriptor_f =
 450 {
 451   print_subexp_f,
 452   operator_length_f,
 453   operator_check_f,
 454   op_name_f,
 455   dump_subexp_body_f,
 456   evaluate_subexp_f
 457 };
 458
 459 extern const struct language_defn f_language_defn =
 460 {
 461   "fortran",
 462   "Fortran",
 463   language_fortran,
 464   range_check_on,
 465   case_sensitive_off,
 466   array_column_major,
 467   macro_expansion_no,
 468   f_extensions,
 469   &exp_descriptor_f,
 470   f_parse,                      /* parser */
 471   null_post_parser,
 472   f_printchar,                  /* Print character constant */
 473   f_printstr,                   /* function to print string constant */
 474   f_emit_char,                  /* Function to print a single character */
 475   f_print_type,                 /* Print a type using appropriate syntax */
 476   default_print_typedef,        /* Print a typedef using appropriate syntax */
 477   f_val_print,                  /* Print a value using appropriate syntax */
 478   c_value_print,                /* FIXME */
 479   default_read_var_value,       /* la_read_var_value */
 480   NULL,                         /* Language specific skip_trampoline */
 481   NULL,                         /* name_of_this */
 482   false,                        /* la_store_sym_names_in_linkage_form_p */
 483   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 484   basic_lookup_transparent_type,/* lookup_transparent_type */
 485
 486   /* We could support demangling here to provide module namespaces
 487      also for inferiors with only minimal symbol table (ELF symbols).
 488      Just the mangling standard is not standardized across compilers
 489      and there is no DW_AT_producer available for inferiors with only
 490      the ELF symbols to check the mangling kind.  */
 491   NULL,                         /* Language specific symbol demangler */
 492   NULL,
 493   NULL,                         /* Language specific
 494                                    class_name_from_physname */
 495   f_op_print_tab,               /* expression operators for printing */
 496   0,                            /* arrays are first-class (not c-style) */
 497   1,                            /* String lower bound */
 498   f_word_break_characters,
 499   f_collect_symbol_completion_matches,
 500   f_language_arch_info,
 501   default_print_array_index,
 502   default_pass_by_reference,
 503   default_get_string,
 504   c_watch_location_expression,
 505   NULL,                         /* la_get_symbol_name_matcher */
 506   iterate_over_symbols,
 507   default_search_name_hash,
 508   &default_varobj_ops,
 509   NULL,
 510   NULL,
 511   f_is_string_type_p,
 512   "(...)"                       /* la_struct_too_deep_ellipsis */
 513 };
 514
 515 static void *
 516 build_fortran_types (struct gdbarch *gdbarch)
 517 {
 518   struct builtin_f_type *builtin_f_type
 519     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 520
 521   builtin_f_type->builtin_void
 522     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID");
 523
 524   builtin_f_type->builtin_character
 525     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 526
 527   builtin_f_type->builtin_logical_s1
 528     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 529
 530   builtin_f_type->builtin_integer_s2
 531     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 532                          "integer*2");
 533
 534   builtin_f_type->builtin_integer_s8
 535     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 536                          "integer*8");
 537
 538   builtin_f_type->builtin_logical_s2
 539     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 540                          "logical*2");
 541
 542   builtin_f_type->builtin_logical_s8
 543     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 544                          "logical*8");
 545
 546   builtin_f_type->builtin_integer
 547     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 548                          "integer");
 549
 550   builtin_f_type->builtin_logical
 551     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 552                          "logical*4");
 553
 554   builtin_f_type->builtin_real
 555     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 556                        "real", gdbarch_float_format (gdbarch));
 557   builtin_f_type->builtin_real_s8
 558     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 559                        "real*8", gdbarch_double_format (gdbarch));
 560   builtin_f_type->builtin_real_s16
 561     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 562                        "real*16", gdbarch_long_double_format (gdbarch));
 563
 564   builtin_f_type->builtin_complex_s8
 565     = arch_complex_type (gdbarch, "complex*8",
 566                          builtin_f_type->builtin_real);
 567   builtin_f_type->builtin_complex_s16
 568     = arch_complex_type (gdbarch, "complex*16",
 569                          builtin_f_type->builtin_real_s8);
 570   builtin_f_type->builtin_complex_s32
 571     = arch_complex_type (gdbarch, "complex*32",
 572                          builtin_f_type->builtin_real_s16);
 573
 574   return builtin_f_type;
 575 }
 576
 577 static struct gdbarch_data *f_type_data;
 578
 579 const struct builtin_f_type *
 580 builtin_f_type (struct gdbarch *gdbarch)
 581 {
 582   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 583 }
 584
 585 void
 586 _initialize_f_language (void)
 587 {
 588   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 589 }
 590
 591 /* See f-lang.h.  */
 592
 593 struct value *
 594 fortran_argument_convert (struct value *value, bool is_artificial)
 595 {
 596   if (!is_artificial)
 597     {
 598       /* If the value is not in the inferior e.g. registers values,
 599          convenience variables and user input.  */
 600       if (VALUE_LVAL (value) != lval_memory)
 601         {
 602           struct type *type = value_type (value);
 603           const int length = TYPE_LENGTH (type);
 604           const CORE_ADDR addr
 605             = value_as_long (value_allocate_space_in_inferior (length));
 606           write_memory (addr, value_contents (value), length);
 607           struct value *val
 608             = value_from_contents_and_address (type, value_contents (value),
 609                                                addr);
 610           return value_addr (val);
 611         }
 612       else
 613         return value_addr (value); /* Program variables, e.g. arrays.  */
 614     }
 615     return value;
 616 }
 617
 618 /* See f-lang.h.  */
 619
 620 struct type *
 621 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 622 {
 623   if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
 624     return value_type (arg);
 625   return type;
 626 }