gdb/f-lang.c

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