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