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 #include "gdbarch.h"
  39
  40 #include <math.h>
  41
  42 /* Local functions */
  43
  44 static void f_printchar (int c, struct type *type, struct ui_file * stream);
  45 static void f_emit_char (int c, struct type *type,
  46                          struct ui_file * stream, int quoter);
  47
  48 /* Return the encoding that should be used for the character type
  49    TYPE.  */
  50
  51 static const char *
  52 f_get_encoding (struct type *type)
  53 {
  54   const char *encoding;
  55
  56   switch (TYPE_LENGTH (type))
  57     {
  58     case 1:
  59       encoding = target_charset (get_type_arch (type));
  60       break;
  61     case 4:
  62       if (gdbarch_byte_order (get_type_arch (type)) == BFD_ENDIAN_BIG)
  63         encoding = "UTF-32BE";
  64       else
  65         encoding = "UTF-32LE";
  66       break;
  67
  68     default:
  69       error (_("unrecognized character type"));
  70     }
  71
  72   return encoding;
  73 }
  74
  75 /* Print the character C on STREAM as part of the contents of a literal
  76    string whose delimiter is QUOTER.  Note that that format for printing
  77    characters and strings is language specific.
  78    FIXME:  This is a copy of the same function from c-exp.y.  It should
  79    be replaced with a true F77 version.  */
  80
  81 static void
  82 f_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
  83 {
  84   const char *encoding = f_get_encoding (type);
  85
  86   generic_emit_char (c, type, stream, quoter, encoding);
  87 }
  88
  89 /* Implementation of la_printchar.  */
  90
  91 static void
  92 f_printchar (int c, struct type *type, struct ui_file *stream)
  93 {
  94   fputs_filtered ("'", stream);
  95   LA_EMIT_CHAR (c, type, stream, '\'');
  96   fputs_filtered ("'", stream);
  97 }
  98
  99 /* Print the character string STRING, printing at most LENGTH characters.
 100    Printing stops early if the number hits print_max; repeat counts
 101    are printed as appropriate.  Print ellipses at the end if we
 102    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
 103    FIXME:  This is a copy of the same function from c-exp.y.  It should
 104    be replaced with a true F77 version.  */
 105
 106 static void
 107 f_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
 108             unsigned int length, const char *encoding, int force_ellipses,
 109             const struct value_print_options *options)
 110 {
 111   const char *type_encoding = f_get_encoding (type);
 112
 113   if (TYPE_LENGTH (type) == 4)
 114     fputs_filtered ("4_", stream);
 115
 116   if (!encoding || !*encoding)
 117     encoding = type_encoding;
 118
 119   generic_printstr (stream, type, string, length, encoding,
 120                     force_ellipses, '\'', 0, options);
 121 }
 122 \f
 123
 124 /* Table of operators and their precedences for printing expressions.  */
 125
 126 static const struct op_print f_op_print_tab[] =
 127 {
 128   {"+", BINOP_ADD, PREC_ADD, 0},
 129   {"+", UNOP_PLUS, PREC_PREFIX, 0},
 130   {"-", BINOP_SUB, PREC_ADD, 0},
 131   {"-", UNOP_NEG, PREC_PREFIX, 0},
 132   {"*", BINOP_MUL, PREC_MUL, 0},
 133   {"/", BINOP_DIV, PREC_MUL, 0},
 134   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
 135   {"MOD", BINOP_REM, PREC_MUL, 0},
 136   {"=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 137   {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 138   {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 139   {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 140   {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0},
 141   {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 142   {".LE.", BINOP_LEQ, PREC_ORDER, 0},
 143   {".GE.", BINOP_GEQ, PREC_ORDER, 0},
 144   {".GT.", BINOP_GTR, PREC_ORDER, 0},
 145   {".LT.", BINOP_LESS, PREC_ORDER, 0},
 146   {"**", UNOP_IND, PREC_PREFIX, 0},
 147   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 148   {NULL, OP_NULL, PREC_REPEAT, 0}
 149 };
 150 \f
 151 enum f_primitive_types {
 152   f_primitive_type_character,
 153   f_primitive_type_logical,
 154   f_primitive_type_logical_s1,
 155   f_primitive_type_logical_s2,
 156   f_primitive_type_logical_s8,
 157   f_primitive_type_integer,
 158   f_primitive_type_integer_s2,
 159   f_primitive_type_real,
 160   f_primitive_type_real_s8,
 161   f_primitive_type_real_s16,
 162   f_primitive_type_complex_s8,
 163   f_primitive_type_complex_s16,
 164   f_primitive_type_void,
 165   nr_f_primitive_types
 166 };
 167
 168 static void
 169 f_language_arch_info (struct gdbarch *gdbarch,
 170                       struct language_arch_info *lai)
 171 {
 172   const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
 173
 174   lai->string_char_type = builtin->builtin_character;
 175   lai->primitive_type_vector
 176     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
 177                               struct type *);
 178
 179   lai->primitive_type_vector [f_primitive_type_character]
 180     = builtin->builtin_character;
 181   lai->primitive_type_vector [f_primitive_type_logical]
 182     = builtin->builtin_logical;
 183   lai->primitive_type_vector [f_primitive_type_logical_s1]
 184     = builtin->builtin_logical_s1;
 185   lai->primitive_type_vector [f_primitive_type_logical_s2]
 186     = builtin->builtin_logical_s2;
 187   lai->primitive_type_vector [f_primitive_type_logical_s8]
 188     = builtin->builtin_logical_s8;
 189   lai->primitive_type_vector [f_primitive_type_real]
 190     = builtin->builtin_real;
 191   lai->primitive_type_vector [f_primitive_type_real_s8]
 192     = builtin->builtin_real_s8;
 193   lai->primitive_type_vector [f_primitive_type_real_s16]
 194     = builtin->builtin_real_s16;
 195   lai->primitive_type_vector [f_primitive_type_complex_s8]
 196     = builtin->builtin_complex_s8;
 197   lai->primitive_type_vector [f_primitive_type_complex_s16]
 198     = builtin->builtin_complex_s16;
 199   lai->primitive_type_vector [f_primitive_type_void]
 200     = builtin->builtin_void;
 201
 202   lai->bool_type_symbol = "logical";
 203   lai->bool_type_default = builtin->builtin_logical_s2;
 204 }
 205
 206 /* Remove the modules separator :: from the default break list.  */
 207
 208 static const char *
 209 f_word_break_characters (void)
 210 {
 211   static char *retval;
 212
 213   if (!retval)
 214     {
 215       char *s;
 216
 217       retval = xstrdup (default_word_break_characters ());
 218       s = strchr (retval, ':');
 219       if (s)
 220         {
 221           char *last_char = &s[strlen (s) - 1];
 222
 223           *s = *last_char;
 224           *last_char = 0;
 225         }
 226     }
 227   return retval;
 228 }
 229
 230 /* Consider the modules separator :: as a valid symbol name character
 231    class.  */
 232
 233 static void
 234 f_collect_symbol_completion_matches (completion_tracker &tracker,
 235                                      complete_symbol_mode mode,
 236                                      symbol_name_match_type compare_name,
 237                                      const char *text, const char *word,
 238                                      enum type_code code)
 239 {
 240   default_collect_symbol_completion_matches_break_on (tracker, mode,
 241                                                       compare_name,
 242                                                       text, word, ":", code);
 243 }
 244
 245 /* Special expression evaluation cases for Fortran.  */
 246 struct value *
 247 evaluate_subexp_f (struct type *expect_type, struct expression *exp,
 248                    int *pos, enum noside noside)
 249 {
 250   struct value *arg1 = NULL, *arg2 = NULL;
 251   enum exp_opcode op;
 252   int pc;
 253   struct type *type;
 254
 255   pc = *pos;
 256   *pos += 1;
 257   op = exp->elts[pc].opcode;
 258
 259   switch (op)
 260     {
 261     default:
 262       *pos -= 1;
 263       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 264
 265     case UNOP_ABS:
 266       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 267       if (noside == EVAL_SKIP)
 268         return eval_skip_value (exp);
 269       type = value_type (arg1);
 270       switch (TYPE_CODE (type))
 271         {
 272         case TYPE_CODE_FLT:
 273           {
 274             double d
 275               = fabs (target_float_to_host_double (value_contents (arg1),
 276                                                    value_type (arg1)));
 277             return value_from_host_double (type, d);
 278           }
 279         case TYPE_CODE_INT:
 280           {
 281             LONGEST l = value_as_long (arg1);
 282             l = llabs (l);
 283             return value_from_longest (type, l);
 284           }
 285         }
 286       error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
 287
 288     case BINOP_MOD:
 289       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 290       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 291       if (noside == EVAL_SKIP)
 292         return eval_skip_value (exp);
 293       type = value_type (arg1);
 294       if (TYPE_CODE (type) != TYPE_CODE (value_type (arg2)))
 295         error (_("non-matching types for parameters to MOD ()"));
 296       switch (TYPE_CODE (type))
 297         {
 298         case TYPE_CODE_FLT:
 299           {
 300             double d1
 301               = target_float_to_host_double (value_contents (arg1),
 302                                              value_type (arg1));
 303             double d2
 304               = target_float_to_host_double (value_contents (arg2),
 305                                              value_type (arg2));
 306             double d3 = fmod (d1, d2);
 307             return value_from_host_double (type, d3);
 308           }
 309         case TYPE_CODE_INT:
 310           {
 311             LONGEST v1 = value_as_long (arg1);
 312             LONGEST v2 = value_as_long (arg2);
 313             if (v2 == 0)
 314               error (_("calling MOD (N, 0) is undefined"));
 315             LONGEST v3 = v1 - (v1 / v2) * v2;
 316             return value_from_longest (value_type (arg1), v3);
 317           }
 318         }
 319       error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
 320
 321     case UNOP_FORTRAN_CEILING:
 322       {
 323         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 324         if (noside == EVAL_SKIP)
 325           return eval_skip_value (exp);
 326         type = value_type (arg1);
 327         if (TYPE_CODE (type) != TYPE_CODE_FLT)
 328           error (_("argument to CEILING must be of type float"));
 329         double val
 330           = target_float_to_host_double (value_contents (arg1),
 331                                          value_type (arg1));
 332         val = ceil (val);
 333         return value_from_host_double (type, val);
 334       }
 335
 336     case UNOP_FORTRAN_FLOOR:
 337       {
 338         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 339         if (noside == EVAL_SKIP)
 340           return eval_skip_value (exp);
 341         type = value_type (arg1);
 342         if (TYPE_CODE (type) != TYPE_CODE_FLT)
 343           error (_("argument to FLOOR must be of type float"));
 344         double val
 345           = target_float_to_host_double (value_contents (arg1),
 346                                          value_type (arg1));
 347         val = floor (val);
 348         return value_from_host_double (type, val);
 349       }
 350
 351     case BINOP_FORTRAN_MODULO:
 352       {
 353         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 354         arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 355         if (noside == EVAL_SKIP)
 356           return eval_skip_value (exp);
 357         type = value_type (arg1);
 358         if (TYPE_CODE (type) != TYPE_CODE (value_type (arg2)))
 359           error (_("non-matching types for parameters to MODULO ()"));
 360         /* MODULO(A, P) = A - FLOOR (A / P) * P */
 361         switch (TYPE_CODE (type))
 362           {
 363           case TYPE_CODE_INT:
 364             {
 365               LONGEST a = value_as_long (arg1);
 366               LONGEST p = value_as_long (arg2);
 367               LONGEST result = a - (a / p) * p;
 368               if (result != 0 && (a < 0) != (p < 0))
 369                 result += p;
 370               return value_from_longest (value_type (arg1), result);
 371             }
 372           case TYPE_CODE_FLT:
 373             {
 374               double a
 375                 = target_float_to_host_double (value_contents (arg1),
 376                                                value_type (arg1));
 377               double p
 378                 = target_float_to_host_double (value_contents (arg2),
 379                                                value_type (arg2));
 380               double result = fmod (a, p);
 381               if (result != 0 && (a < 0.0) != (p < 0.0))
 382                 result += p;
 383               return value_from_host_double (type, result);
 384             }
 385           }
 386         error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
 387       }
 388
 389     case BINOP_FORTRAN_CMPLX:
 390       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 391       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 392       if (noside == EVAL_SKIP)
 393         return eval_skip_value (exp);
 394       type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
 395       return value_literal_complex (arg1, arg2, type);
 396
 397     case UNOP_FORTRAN_KIND:
 398       arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
 399       type = value_type (arg1);
 400
 401       switch (TYPE_CODE (type))
 402         {
 403           case TYPE_CODE_STRUCT:
 404           case TYPE_CODE_UNION:
 405           case TYPE_CODE_MODULE:
 406           case TYPE_CODE_FUNC:
 407             error (_("argument to kind must be an intrinsic type"));
 408         }
 409
 410       if (!TYPE_TARGET_TYPE (type))
 411         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 412                                    TYPE_LENGTH (type));
 413       return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 414                                  TYPE_LENGTH (TYPE_TARGET_TYPE(type)));
 415     }
 416
 417   /* Should be unreachable.  */
 418   return nullptr;
 419 }
 420
 421 /* Return true if TYPE is a string.  */
 422
 423 static bool
 424 f_is_string_type_p (struct type *type)
 425 {
 426   type = check_typedef (type);
 427   return (TYPE_CODE (type) == TYPE_CODE_STRING
 428           || (TYPE_CODE (type) == TYPE_CODE_ARRAY
 429               && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_CHAR));
 430 }
 431
 432 /* Special expression lengths for Fortran.  */
 433
 434 static void
 435 operator_length_f (const struct expression *exp, int pc, int *oplenp,
 436                    int *argsp)
 437 {
 438   int oplen = 1;
 439   int args = 0;
 440
 441   switch (exp->elts[pc - 1].opcode)
 442     {
 443     default:
 444       operator_length_standard (exp, pc, oplenp, argsp);
 445       return;
 446
 447     case UNOP_FORTRAN_KIND:
 448     case UNOP_FORTRAN_FLOOR:
 449     case UNOP_FORTRAN_CEILING:
 450       oplen = 1;
 451       args = 1;
 452       break;
 453
 454     case BINOP_FORTRAN_CMPLX:
 455     case BINOP_FORTRAN_MODULO:
 456       oplen = 1;
 457       args = 2;
 458       break;
 459     }
 460
 461   *oplenp = oplen;
 462   *argsp = args;
 463 }
 464
 465 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 466    the extra argument NAME which is the text that should be printed as the
 467    name of this operation.  */
 468
 469 static void
 470 print_unop_subexp_f (struct expression *exp, int *pos,
 471                      struct ui_file *stream, enum precedence prec,
 472                      const char *name)
 473 {
 474   (*pos)++;
 475   fprintf_filtered (stream, "%s(", name);
 476   print_subexp (exp, pos, stream, PREC_SUFFIX);
 477   fputs_filtered (")", stream);
 478 }
 479
 480 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 481    the extra argument NAME which is the text that should be printed as the
 482    name of this operation.  */
 483
 484 static void
 485 print_binop_subexp_f (struct expression *exp, int *pos,
 486                       struct ui_file *stream, enum precedence prec,
 487                       const char *name)
 488 {
 489   (*pos)++;
 490   fprintf_filtered (stream, "%s(", name);
 491   print_subexp (exp, pos, stream, PREC_SUFFIX);
 492   fputs_filtered (",", stream);
 493   print_subexp (exp, pos, stream, PREC_SUFFIX);
 494   fputs_filtered (")", stream);
 495 }
 496
 497 /* Special expression printing for Fortran.  */
 498
 499 static void
 500 print_subexp_f (struct expression *exp, int *pos,
 501                 struct ui_file *stream, enum precedence prec)
 502 {
 503   int pc = *pos;
 504   enum exp_opcode op = exp->elts[pc].opcode;
 505
 506   switch (op)
 507     {
 508     default:
 509       print_subexp_standard (exp, pos, stream, prec);
 510       return;
 511
 512     case UNOP_FORTRAN_KIND:
 513       print_unop_subexp_f (exp, pos, stream, prec, "KIND");
 514       return;
 515
 516     case UNOP_FORTRAN_FLOOR:
 517       print_unop_subexp_f (exp, pos, stream, prec, "FLOOR");
 518       return;
 519
 520     case UNOP_FORTRAN_CEILING:
 521       print_unop_subexp_f (exp, pos, stream, prec, "CEILING");
 522       return;
 523
 524     case BINOP_FORTRAN_CMPLX:
 525       print_binop_subexp_f (exp, pos, stream, prec, "CMPLX");
 526       return;
 527
 528     case BINOP_FORTRAN_MODULO:
 529       print_binop_subexp_f (exp, pos, stream, prec, "MODULO");
 530       return;
 531     }
 532 }
 533
 534 /* Special expression names for Fortran.  */
 535
 536 static const char *
 537 op_name_f (enum exp_opcode opcode)
 538 {
 539   switch (opcode)
 540     {
 541     default:
 542       return op_name_standard (opcode);
 543
 544 #define OP(name)        \
 545     case name:          \
 546       return #name ;
 547 #include "fortran-operator.def"
 548 #undef OP
 549     }
 550 }
 551
 552 /* Special expression dumping for Fortran.  */
 553
 554 static int
 555 dump_subexp_body_f (struct expression *exp,
 556                     struct ui_file *stream, int elt)
 557 {
 558   int opcode = exp->elts[elt].opcode;
 559   int oplen, nargs, i;
 560
 561   switch (opcode)
 562     {
 563     default:
 564       return dump_subexp_body_standard (exp, stream, elt);
 565
 566     case UNOP_FORTRAN_KIND:
 567     case UNOP_FORTRAN_FLOOR:
 568     case UNOP_FORTRAN_CEILING:
 569     case BINOP_FORTRAN_CMPLX:
 570     case BINOP_FORTRAN_MODULO:
 571       operator_length_f (exp, (elt + 1), &oplen, &nargs);
 572       break;
 573     }
 574
 575   elt += oplen;
 576   for (i = 0; i < nargs; i += 1)
 577     elt = dump_subexp (exp, stream, elt);
 578
 579   return elt;
 580 }
 581
 582 /* Special expression checking for Fortran.  */
 583
 584 static int
 585 operator_check_f (struct expression *exp, int pos,
 586                   int (*objfile_func) (struct objfile *objfile,
 587                                        void *data),
 588                   void *data)
 589 {
 590   const union exp_element *const elts = exp->elts;
 591
 592   switch (elts[pos].opcode)
 593     {
 594     case UNOP_FORTRAN_KIND:
 595     case UNOP_FORTRAN_FLOOR:
 596     case UNOP_FORTRAN_CEILING:
 597     case BINOP_FORTRAN_CMPLX:
 598     case BINOP_FORTRAN_MODULO:
 599       /* Any references to objfiles are held in the arguments to this
 600          expression, not within the expression itself, so no additional
 601          checking is required here, the outer expression iteration code
 602          will take care of checking each argument.  */
 603       break;
 604
 605     default:
 606       return operator_check_standard (exp, pos, objfile_func, data);
 607     }
 608
 609   return 0;
 610 }
 611
 612 static const char *f_extensions[] =
 613 {
 614   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 615   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 616   NULL
 617 };
 618
 619 /* Expression processing for Fortran.  */
 620 static const struct exp_descriptor exp_descriptor_f =
 621 {
 622   print_subexp_f,
 623   operator_length_f,
 624   operator_check_f,
 625   op_name_f,
 626   dump_subexp_body_f,
 627   evaluate_subexp_f
 628 };
 629
 630 extern const struct language_defn f_language_defn =
 631 {
 632   "fortran",
 633   "Fortran",
 634   language_fortran,
 635   range_check_on,
 636   case_sensitive_off,
 637   array_column_major,
 638   macro_expansion_no,
 639   f_extensions,
 640   &exp_descriptor_f,
 641   f_parse,                      /* parser */
 642   null_post_parser,
 643   f_printchar,                  /* Print character constant */
 644   f_printstr,                   /* function to print string constant */
 645   f_emit_char,                  /* Function to print a single character */
 646   f_print_type,                 /* Print a type using appropriate syntax */
 647   f_print_typedef,              /* Print a typedef using appropriate syntax */
 648   f_val_print,                  /* Print a value using appropriate syntax */
 649   c_value_print,                /* FIXME */
 650   default_read_var_value,       /* la_read_var_value */
 651   NULL,                         /* Language specific skip_trampoline */
 652   NULL,                         /* name_of_this */
 653   false,                        /* la_store_sym_names_in_linkage_form_p */
 654   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 655   basic_lookup_transparent_type,/* lookup_transparent_type */
 656
 657   /* We could support demangling here to provide module namespaces
 658      also for inferiors with only minimal symbol table (ELF symbols).
 659      Just the mangling standard is not standardized across compilers
 660      and there is no DW_AT_producer available for inferiors with only
 661      the ELF symbols to check the mangling kind.  */
 662   NULL,                         /* Language specific symbol demangler */
 663   NULL,
 664   NULL,                         /* Language specific
 665                                    class_name_from_physname */
 666   f_op_print_tab,               /* expression operators for printing */
 667   0,                            /* arrays are first-class (not c-style) */
 668   1,                            /* String lower bound */
 669   f_word_break_characters,
 670   f_collect_symbol_completion_matches,
 671   f_language_arch_info,
 672   default_print_array_index,
 673   default_pass_by_reference,
 674   default_get_string,
 675   c_watch_location_expression,
 676   NULL,                         /* la_get_symbol_name_matcher */
 677   iterate_over_symbols,
 678   default_search_name_hash,
 679   &default_varobj_ops,
 680   NULL,
 681   NULL,
 682   f_is_string_type_p,
 683   "(...)"                       /* la_struct_too_deep_ellipsis */
 684 };
 685
 686 static void *
 687 build_fortran_types (struct gdbarch *gdbarch)
 688 {
 689   struct builtin_f_type *builtin_f_type
 690     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 691
 692   builtin_f_type->builtin_void
 693     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
 694
 695   builtin_f_type->builtin_character
 696     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 697
 698   builtin_f_type->builtin_logical_s1
 699     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 700
 701   builtin_f_type->builtin_integer_s2
 702     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 703                          "integer*2");
 704
 705   builtin_f_type->builtin_integer_s8
 706     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 707                          "integer*8");
 708
 709   builtin_f_type->builtin_logical_s2
 710     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 711                          "logical*2");
 712
 713   builtin_f_type->builtin_logical_s8
 714     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 715                          "logical*8");
 716
 717   builtin_f_type->builtin_integer
 718     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 719                          "integer");
 720
 721   builtin_f_type->builtin_logical
 722     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 723                          "logical*4");
 724
 725   builtin_f_type->builtin_real
 726     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 727                        "real", gdbarch_float_format (gdbarch));
 728   builtin_f_type->builtin_real_s8
 729     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 730                        "real*8", gdbarch_double_format (gdbarch));
 731   auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
 732   if (fmt != nullptr)
 733     builtin_f_type->builtin_real_s16
 734       = arch_float_type (gdbarch, 128, "real*16", fmt);
 735   else if (gdbarch_long_double_bit (gdbarch) == 128)
 736     builtin_f_type->builtin_real_s16
 737       = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 738                          "real*16", gdbarch_long_double_format (gdbarch));
 739   else
 740     builtin_f_type->builtin_real_s16
 741       = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
 742
 743   builtin_f_type->builtin_complex_s8
 744     = arch_complex_type (gdbarch, "complex*8",
 745                          builtin_f_type->builtin_real);
 746   builtin_f_type->builtin_complex_s16
 747     = arch_complex_type (gdbarch, "complex*16",
 748                          builtin_f_type->builtin_real_s8);
 749   builtin_f_type->builtin_complex_s32
 750     = arch_complex_type (gdbarch, "complex*32",
 751                          builtin_f_type->builtin_real_s16);
 752
 753   return builtin_f_type;
 754 }
 755
 756 static struct gdbarch_data *f_type_data;
 757
 758 const struct builtin_f_type *
 759 builtin_f_type (struct gdbarch *gdbarch)
 760 {
 761   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 762 }
 763
 764 void
 765 _initialize_f_language (void)
 766 {
 767   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 768 }
 769
 770 /* See f-lang.h.  */
 771
 772 struct value *
 773 fortran_argument_convert (struct value *value, bool is_artificial)
 774 {
 775   if (!is_artificial)
 776     {
 777       /* If the value is not in the inferior e.g. registers values,
 778          convenience variables and user input.  */
 779       if (VALUE_LVAL (value) != lval_memory)
 780         {
 781           struct type *type = value_type (value);
 782           const int length = TYPE_LENGTH (type);
 783           const CORE_ADDR addr
 784             = value_as_long (value_allocate_space_in_inferior (length));
 785           write_memory (addr, value_contents (value), length);
 786           struct value *val
 787             = value_from_contents_and_address (type, value_contents (value),
 788                                                addr);
 789           return value_addr (val);
 790         }
 791       else
 792         return value_addr (value); /* Program variables, e.g. arrays.  */
 793     }
 794     return value;
 795 }
 796
 797 /* See f-lang.h.  */
 798
 799 struct type *
 800 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 801 {
 802   if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
 803     return value_type (arg);
 804   return type;
 805 }