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, *arg2 = 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 BINOP_MOD:
 288       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 289       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 290       if (noside == EVAL_SKIP)
 291         return eval_skip_value (exp);
 292       type = value_type (arg1);
 293       if (TYPE_CODE (type) != TYPE_CODE (value_type (arg2)))
 294         error (_("non-matching types for parameters to MOD ()"));
 295       switch (TYPE_CODE (type))
 296         {
 297         case TYPE_CODE_FLT:
 298           {
 299             double d1
 300               = target_float_to_host_double (value_contents (arg1),
 301                                              value_type (arg1));
 302             double d2
 303               = target_float_to_host_double (value_contents (arg2),
 304                                              value_type (arg2));
 305             double d3 = fmod (d1, d2);
 306             return value_from_host_double (type, d3);
 307           }
 308         case TYPE_CODE_INT:
 309           {
 310             LONGEST v1 = value_as_long (arg1);
 311             LONGEST v2 = value_as_long (arg2);
 312             if (v2 == 0)
 313               error (_("calling MOD (N, 0) is undefined"));
 314             LONGEST v3 = v1 - (v1 / v2) * v2;
 315             return value_from_longest (value_type (arg1), v3);
 316           }
 317         }
 318       error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
 319
 320     case UNOP_FORTRAN_CEILING:
 321       {
 322         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 323         if (noside == EVAL_SKIP)
 324           return eval_skip_value (exp);
 325         type = value_type (arg1);
 326         if (TYPE_CODE (type) != TYPE_CODE_FLT)
 327           error (_("argument to CEILING must be of type float"));
 328         double val
 329           = target_float_to_host_double (value_contents (arg1),
 330                                          value_type (arg1));
 331         val = ceil (val);
 332         return value_from_host_double (type, val);
 333       }
 334
 335     case UNOP_FORTRAN_FLOOR:
 336       {
 337         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 338         if (noside == EVAL_SKIP)
 339           return eval_skip_value (exp);
 340         type = value_type (arg1);
 341         if (TYPE_CODE (type) != TYPE_CODE_FLT)
 342           error (_("argument to FLOOR must be of type float"));
 343         double val
 344           = target_float_to_host_double (value_contents (arg1),
 345                                          value_type (arg1));
 346         val = floor (val);
 347         return value_from_host_double (type, val);
 348       }
 349
 350     case BINOP_FORTRAN_MODULO:
 351       {
 352         arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 353         arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 354         if (noside == EVAL_SKIP)
 355           return eval_skip_value (exp);
 356         type = value_type (arg1);
 357         if (TYPE_CODE (type) != TYPE_CODE (value_type (arg2)))
 358           error (_("non-matching types for parameters to MODULO ()"));
 359         /* MODULO(A, P) = A - FLOOR (A / P) * P */
 360         switch (TYPE_CODE (type))
 361           {
 362           case TYPE_CODE_INT:
 363             {
 364               LONGEST a = value_as_long (arg1);
 365               LONGEST p = value_as_long (arg2);
 366               LONGEST result = a - (a / p) * p;
 367               if (result != 0 && (a < 0) != (p < 0))
 368                 result += p;
 369               return value_from_longest (value_type (arg1), result);
 370             }
 371           case TYPE_CODE_FLT:
 372             {
 373               double a
 374                 = target_float_to_host_double (value_contents (arg1),
 375                                                value_type (arg1));
 376               double p
 377                 = target_float_to_host_double (value_contents (arg2),
 378                                                value_type (arg2));
 379               double result = fmod (a, p);
 380               if (result != 0 && (a < 0.0) != (p < 0.0))
 381                 result += p;
 382               return value_from_host_double (type, result);
 383             }
 384           }
 385         error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
 386       }
 387
 388     case BINOP_FORTRAN_CMPLX:
 389       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 390       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 391       if (noside == EVAL_SKIP)
 392         return eval_skip_value (exp);
 393       type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
 394       return value_literal_complex (arg1, arg2, type);
 395
 396     case UNOP_FORTRAN_KIND:
 397       arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
 398       type = value_type (arg1);
 399
 400       switch (TYPE_CODE (type))
 401         {
 402           case TYPE_CODE_STRUCT:
 403           case TYPE_CODE_UNION:
 404           case TYPE_CODE_MODULE:
 405           case TYPE_CODE_FUNC:
 406             error (_("argument to kind must be an intrinsic type"));
 407         }
 408
 409       if (!TYPE_TARGET_TYPE (type))
 410         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 411                                    TYPE_LENGTH (type));
 412       return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 413                                  TYPE_LENGTH (TYPE_TARGET_TYPE(type)));
 414     }
 415
 416   /* Should be unreachable.  */
 417   return nullptr;
 418 }
 419
 420 /* Return true if TYPE is a string.  */
 421
 422 static bool
 423 f_is_string_type_p (struct type *type)
 424 {
 425   type = check_typedef (type);
 426   return (TYPE_CODE (type) == TYPE_CODE_STRING
 427           || (TYPE_CODE (type) == TYPE_CODE_ARRAY
 428               && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_CHAR));
 429 }
 430
 431 /* Special expression lengths for Fortran.  */
 432
 433 static void
 434 operator_length_f (const struct expression *exp, int pc, int *oplenp,
 435                    int *argsp)
 436 {
 437   int oplen = 1;
 438   int args = 0;
 439
 440   switch (exp->elts[pc - 1].opcode)
 441     {
 442     default:
 443       operator_length_standard (exp, pc, oplenp, argsp);
 444       return;
 445
 446     case UNOP_FORTRAN_KIND:
 447     case UNOP_FORTRAN_FLOOR:
 448     case UNOP_FORTRAN_CEILING:
 449       oplen = 1;
 450       args = 1;
 451       break;
 452
 453     case BINOP_FORTRAN_CMPLX:
 454     case BINOP_FORTRAN_MODULO:
 455       oplen = 1;
 456       args = 2;
 457       break;
 458     }
 459
 460   *oplenp = oplen;
 461   *argsp = args;
 462 }
 463
 464 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 465    the extra argument NAME which is the text that should be printed as the
 466    name of this operation.  */
 467
 468 static void
 469 print_unop_subexp_f (struct expression *exp, int *pos,
 470                      struct ui_file *stream, enum precedence prec,
 471                      const char *name)
 472 {
 473   (*pos)++;
 474   fprintf_filtered (stream, "%s(", name);
 475   print_subexp (exp, pos, stream, PREC_SUFFIX);
 476   fputs_filtered (")", stream);
 477 }
 478
 479 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 480    the extra argument NAME which is the text that should be printed as the
 481    name of this operation.  */
 482
 483 static void
 484 print_binop_subexp_f (struct expression *exp, int *pos,
 485                       struct ui_file *stream, enum precedence prec,
 486                       const char *name)
 487 {
 488   (*pos)++;
 489   fprintf_filtered (stream, "%s(", name);
 490   print_subexp (exp, pos, stream, PREC_SUFFIX);
 491   fputs_filtered (",", stream);
 492   print_subexp (exp, pos, stream, PREC_SUFFIX);
 493   fputs_filtered (")", stream);
 494 }
 495
 496 /* Special expression printing for Fortran.  */
 497
 498 static void
 499 print_subexp_f (struct expression *exp, int *pos,
 500                 struct ui_file *stream, enum precedence prec)
 501 {
 502   int pc = *pos;
 503   enum exp_opcode op = exp->elts[pc].opcode;
 504
 505   switch (op)
 506     {
 507     default:
 508       print_subexp_standard (exp, pos, stream, prec);
 509       return;
 510
 511     case UNOP_FORTRAN_KIND:
 512       print_unop_subexp_f (exp, pos, stream, prec, "KIND");
 513       return;
 514
 515     case UNOP_FORTRAN_FLOOR:
 516       print_unop_subexp_f (exp, pos, stream, prec, "FLOOR");
 517       return;
 518
 519     case UNOP_FORTRAN_CEILING:
 520       print_unop_subexp_f (exp, pos, stream, prec, "CEILING");
 521       return;
 522
 523     case BINOP_FORTRAN_CMPLX:
 524       print_binop_subexp_f (exp, pos, stream, prec, "CMPLX");
 525       return;
 526
 527     case BINOP_FORTRAN_MODULO:
 528       print_binop_subexp_f (exp, pos, stream, prec, "MODULO");
 529       return;
 530     }
 531 }
 532
 533 /* Special expression names for Fortran.  */
 534
 535 static const char *
 536 op_name_f (enum exp_opcode opcode)
 537 {
 538   switch (opcode)
 539     {
 540     default:
 541       return op_name_standard (opcode);
 542
 543 #define OP(name)        \
 544     case name:          \
 545       return #name ;
 546 #include "fortran-operator.def"
 547 #undef OP
 548     }
 549 }
 550
 551 /* Special expression dumping for Fortran.  */
 552
 553 static int
 554 dump_subexp_body_f (struct expression *exp,
 555                     struct ui_file *stream, int elt)
 556 {
 557   int opcode = exp->elts[elt].opcode;
 558   int oplen, nargs, i;
 559
 560   switch (opcode)
 561     {
 562     default:
 563       return dump_subexp_body_standard (exp, stream, elt);
 564
 565     case UNOP_FORTRAN_KIND:
 566     case UNOP_FORTRAN_FLOOR:
 567     case UNOP_FORTRAN_CEILING:
 568     case BINOP_FORTRAN_CMPLX:
 569     case BINOP_FORTRAN_MODULO:
 570       operator_length_f (exp, (elt + 1), &oplen, &nargs);
 571       break;
 572     }
 573
 574   elt += oplen;
 575   for (i = 0; i < nargs; i += 1)
 576     elt = dump_subexp (exp, stream, elt);
 577
 578   return elt;
 579 }
 580
 581 /* Special expression checking for Fortran.  */
 582
 583 static int
 584 operator_check_f (struct expression *exp, int pos,
 585                   int (*objfile_func) (struct objfile *objfile,
 586                                        void *data),
 587                   void *data)
 588 {
 589   const union exp_element *const elts = exp->elts;
 590
 591   switch (elts[pos].opcode)
 592     {
 593     case UNOP_FORTRAN_KIND:
 594     case UNOP_FORTRAN_FLOOR:
 595     case UNOP_FORTRAN_CEILING:
 596     case BINOP_FORTRAN_CMPLX:
 597     case BINOP_FORTRAN_MODULO:
 598       /* Any references to objfiles are held in the arguments to this
 599          expression, not within the expression itself, so no additional
 600          checking is required here, the outer expression iteration code
 601          will take care of checking each argument.  */
 602       break;
 603
 604     default:
 605       return operator_check_standard (exp, pos, objfile_func, data);
 606     }
 607
 608   return 0;
 609 }
 610
 611 static const char *f_extensions[] =
 612 {
 613   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 614   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 615   NULL
 616 };
 617
 618 /* Expression processing for Fortran.  */
 619 static const struct exp_descriptor exp_descriptor_f =
 620 {
 621   print_subexp_f,
 622   operator_length_f,
 623   operator_check_f,
 624   op_name_f,
 625   dump_subexp_body_f,
 626   evaluate_subexp_f
 627 };
 628
 629 extern const struct language_defn f_language_defn =
 630 {
 631   "fortran",
 632   "Fortran",
 633   language_fortran,
 634   range_check_on,
 635   case_sensitive_off,
 636   array_column_major,
 637   macro_expansion_no,
 638   f_extensions,
 639   &exp_descriptor_f,
 640   f_parse,                      /* parser */
 641   null_post_parser,
 642   f_printchar,                  /* Print character constant */
 643   f_printstr,                   /* function to print string constant */
 644   f_emit_char,                  /* Function to print a single character */
 645   f_print_type,                 /* Print a type using appropriate syntax */
 646   default_print_typedef,        /* Print a typedef using appropriate syntax */
 647   f_val_print,                  /* Print a value using appropriate syntax */
 648   c_value_print,                /* FIXME */
 649   default_read_var_value,       /* la_read_var_value */
 650   NULL,                         /* Language specific skip_trampoline */
 651   NULL,                         /* name_of_this */
 652   false,                        /* la_store_sym_names_in_linkage_form_p */
 653   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 654   basic_lookup_transparent_type,/* lookup_transparent_type */
 655
 656   /* We could support demangling here to provide module namespaces
 657      also for inferiors with only minimal symbol table (ELF symbols).
 658      Just the mangling standard is not standardized across compilers
 659      and there is no DW_AT_producer available for inferiors with only
 660      the ELF symbols to check the mangling kind.  */
 661   NULL,                         /* Language specific symbol demangler */
 662   NULL,
 663   NULL,                         /* Language specific
 664                                    class_name_from_physname */
 665   f_op_print_tab,               /* expression operators for printing */
 666   0,                            /* arrays are first-class (not c-style) */
 667   1,                            /* String lower bound */
 668   f_word_break_characters,
 669   f_collect_symbol_completion_matches,
 670   f_language_arch_info,
 671   default_print_array_index,
 672   default_pass_by_reference,
 673   default_get_string,
 674   c_watch_location_expression,
 675   NULL,                         /* la_get_symbol_name_matcher */
 676   iterate_over_symbols,
 677   default_search_name_hash,
 678   &default_varobj_ops,
 679   NULL,
 680   NULL,
 681   f_is_string_type_p,
 682   "(...)"                       /* la_struct_too_deep_ellipsis */
 683 };
 684
 685 static void *
 686 build_fortran_types (struct gdbarch *gdbarch)
 687 {
 688   struct builtin_f_type *builtin_f_type
 689     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 690
 691   builtin_f_type->builtin_void
 692     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
 693
 694   builtin_f_type->builtin_character
 695     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 696
 697   builtin_f_type->builtin_logical_s1
 698     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 699
 700   builtin_f_type->builtin_integer_s2
 701     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 702                          "integer*2");
 703
 704   builtin_f_type->builtin_integer_s8
 705     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 706                          "integer*8");
 707
 708   builtin_f_type->builtin_logical_s2
 709     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 710                          "logical*2");
 711
 712   builtin_f_type->builtin_logical_s8
 713     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 714                          "logical*8");
 715
 716   builtin_f_type->builtin_integer
 717     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 718                          "integer");
 719
 720   builtin_f_type->builtin_logical
 721     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 722                          "logical*4");
 723
 724   builtin_f_type->builtin_real
 725     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 726                        "real", gdbarch_float_format (gdbarch));
 727   builtin_f_type->builtin_real_s8
 728     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 729                        "real*8", gdbarch_double_format (gdbarch));
 730   builtin_f_type->builtin_real_s16
 731     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 732                        "real*16", gdbarch_long_double_format (gdbarch));
 733
 734   builtin_f_type->builtin_complex_s8
 735     = arch_complex_type (gdbarch, "complex*8",
 736                          builtin_f_type->builtin_real);
 737   builtin_f_type->builtin_complex_s16
 738     = arch_complex_type (gdbarch, "complex*16",
 739                          builtin_f_type->builtin_real_s8);
 740   builtin_f_type->builtin_complex_s32
 741     = arch_complex_type (gdbarch, "complex*32",
 742                          builtin_f_type->builtin_real_s16);
 743
 744   return builtin_f_type;
 745 }
 746
 747 static struct gdbarch_data *f_type_data;
 748
 749 const struct builtin_f_type *
 750 builtin_f_type (struct gdbarch *gdbarch)
 751 {
 752   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 753 }
 754
 755 void
 756 _initialize_f_language (void)
 757 {
 758   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 759 }
 760
 761 /* See f-lang.h.  */
 762
 763 struct value *
 764 fortran_argument_convert (struct value *value, bool is_artificial)
 765 {
 766   if (!is_artificial)
 767     {
 768       /* If the value is not in the inferior e.g. registers values,
 769          convenience variables and user input.  */
 770       if (VALUE_LVAL (value) != lval_memory)
 771         {
 772           struct type *type = value_type (value);
 773           const int length = TYPE_LENGTH (type);
 774           const CORE_ADDR addr
 775             = value_as_long (value_allocate_space_in_inferior (length));
 776           write_memory (addr, value_contents (value), length);
 777           struct value *val
 778             = value_from_contents_and_address (type, value_contents (value),
 779                                                addr);
 780           return value_addr (val);
 781         }
 782       else
 783         return value_addr (value); /* Program variables, e.g. arrays.  */
 784     }
 785     return value;
 786 }
 787
 788 /* See f-lang.h.  */
 789
 790 struct type *
 791 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 792 {
 793   if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR)
 794     return value_type (arg);
 795   return type;
 796 }