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