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 (nullptr, 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 (nullptr, 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 (nullptr, 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 (nullptr, 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 (nullptr, 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 (nullptr, 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 /* Special expression lengths for Fortran.  */
 295
 296 static void
 297 operator_length_f (const struct expression *exp, int pc, int *oplenp,
 298                    int *argsp)
 299 {
 300   int oplen = 1;
 301   int args = 0;
 302
 303   switch (exp->elts[pc - 1].opcode)
 304     {
 305     default:
 306       operator_length_standard (exp, pc, oplenp, argsp);
 307       return;
 308
 309     case UNOP_FORTRAN_KIND:
 310     case UNOP_FORTRAN_FLOOR:
 311     case UNOP_FORTRAN_CEILING:
 312       oplen = 1;
 313       args = 1;
 314       break;
 315
 316     case BINOP_FORTRAN_CMPLX:
 317     case BINOP_FORTRAN_MODULO:
 318       oplen = 1;
 319       args = 2;
 320       break;
 321     }
 322
 323   *oplenp = oplen;
 324   *argsp = args;
 325 }
 326
 327 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 328    the extra argument NAME which is the text that should be printed as the
 329    name of this operation.  */
 330
 331 static void
 332 print_unop_subexp_f (struct expression *exp, int *pos,
 333                      struct ui_file *stream, enum precedence prec,
 334                      const char *name)
 335 {
 336   (*pos)++;
 337   fprintf_filtered (stream, "%s(", name);
 338   print_subexp (exp, pos, stream, PREC_SUFFIX);
 339   fputs_filtered (")", stream);
 340 }
 341
 342 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 343    the extra argument NAME which is the text that should be printed as the
 344    name of this operation.  */
 345
 346 static void
 347 print_binop_subexp_f (struct expression *exp, int *pos,
 348                       struct ui_file *stream, enum precedence prec,
 349                       const char *name)
 350 {
 351   (*pos)++;
 352   fprintf_filtered (stream, "%s(", name);
 353   print_subexp (exp, pos, stream, PREC_SUFFIX);
 354   fputs_filtered (",", stream);
 355   print_subexp (exp, pos, stream, PREC_SUFFIX);
 356   fputs_filtered (")", stream);
 357 }
 358
 359 /* Special expression printing for Fortran.  */
 360
 361 static void
 362 print_subexp_f (struct expression *exp, int *pos,
 363                 struct ui_file *stream, enum precedence prec)
 364 {
 365   int pc = *pos;
 366   enum exp_opcode op = exp->elts[pc].opcode;
 367
 368   switch (op)
 369     {
 370     default:
 371       print_subexp_standard (exp, pos, stream, prec);
 372       return;
 373
 374     case UNOP_FORTRAN_KIND:
 375       print_unop_subexp_f (exp, pos, stream, prec, "KIND");
 376       return;
 377
 378     case UNOP_FORTRAN_FLOOR:
 379       print_unop_subexp_f (exp, pos, stream, prec, "FLOOR");
 380       return;
 381
 382     case UNOP_FORTRAN_CEILING:
 383       print_unop_subexp_f (exp, pos, stream, prec, "CEILING");
 384       return;
 385
 386     case BINOP_FORTRAN_CMPLX:
 387       print_binop_subexp_f (exp, pos, stream, prec, "CMPLX");
 388       return;
 389
 390     case BINOP_FORTRAN_MODULO:
 391       print_binop_subexp_f (exp, pos, stream, prec, "MODULO");
 392       return;
 393     }
 394 }
 395
 396 /* Special expression names for Fortran.  */
 397
 398 static const char *
 399 op_name_f (enum exp_opcode opcode)
 400 {
 401   switch (opcode)
 402     {
 403     default:
 404       return op_name_standard (opcode);
 405
 406 #define OP(name)        \
 407     case name:          \
 408       return #name ;
 409 #include "fortran-operator.def"
 410 #undef OP
 411     }
 412 }
 413
 414 /* Special expression dumping for Fortran.  */
 415
 416 static int
 417 dump_subexp_body_f (struct expression *exp,
 418                     struct ui_file *stream, int elt)
 419 {
 420   int opcode = exp->elts[elt].opcode;
 421   int oplen, nargs, i;
 422
 423   switch (opcode)
 424     {
 425     default:
 426       return dump_subexp_body_standard (exp, stream, elt);
 427
 428     case UNOP_FORTRAN_KIND:
 429     case UNOP_FORTRAN_FLOOR:
 430     case UNOP_FORTRAN_CEILING:
 431     case BINOP_FORTRAN_CMPLX:
 432     case BINOP_FORTRAN_MODULO:
 433       operator_length_f (exp, (elt + 1), &oplen, &nargs);
 434       break;
 435     }
 436
 437   elt += oplen;
 438   for (i = 0; i < nargs; i += 1)
 439     elt = dump_subexp (exp, stream, elt);
 440
 441   return elt;
 442 }
 443
 444 /* Special expression checking for Fortran.  */
 445
 446 static int
 447 operator_check_f (struct expression *exp, int pos,
 448                   int (*objfile_func) (struct objfile *objfile,
 449                                        void *data),
 450                   void *data)
 451 {
 452   const union exp_element *const elts = exp->elts;
 453
 454   switch (elts[pos].opcode)
 455     {
 456     case UNOP_FORTRAN_KIND:
 457     case UNOP_FORTRAN_FLOOR:
 458     case UNOP_FORTRAN_CEILING:
 459     case BINOP_FORTRAN_CMPLX:
 460     case BINOP_FORTRAN_MODULO:
 461       /* Any references to objfiles are held in the arguments to this
 462          expression, not within the expression itself, so no additional
 463          checking is required here, the outer expression iteration code
 464          will take care of checking each argument.  */
 465       break;
 466
 467     default:
 468       return operator_check_standard (exp, pos, objfile_func, data);
 469     }
 470
 471   return 0;
 472 }
 473
 474 /* Expression processing for Fortran.  */
 475 static const struct exp_descriptor exp_descriptor_f =
 476 {
 477   print_subexp_f,
 478   operator_length_f,
 479   operator_check_f,
 480   op_name_f,
 481   dump_subexp_body_f,
 482   evaluate_subexp_f
 483 };
 484
 485 /* Constant data that describes the Fortran language.  */
 486
 487 extern const struct language_data f_language_data =
 488 {
 489   f_op_print_tab,               /* expression operators for printing */
 490 };
 491
 492 /* Class representing the Fortran language.  */
 493
 494 class f_language : public language_defn
 495 {
 496 public:
 497   f_language ()
 498     : language_defn (language_fortran, f_language_data)
 499   { /* Nothing.  */ }
 500
 501   /* See language.h.  */
 502
 503   const char *name () const override
 504   { return "fortran"; }
 505
 506   /* See language.h.  */
 507
 508   const char *natural_name () const override
 509   { return "Fortran"; }
 510
 511   /* See language.h.  */
 512
 513   const std::vector<const char *> &filename_extensions () const override
 514   {
 515     static const std::vector<const char *> extensions = {
 516       ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 517       ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08"
 518     };
 519     return extensions;
 520   }
 521
 522   /* See language.h.  */
 523   void language_arch_info (struct gdbarch *gdbarch,
 524                            struct language_arch_info *lai) const override
 525   {
 526     const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
 527
 528     lai->string_char_type = builtin->builtin_character;
 529     lai->primitive_type_vector
 530       = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
 531                                 struct type *);
 532
 533     lai->primitive_type_vector [f_primitive_type_character]
 534       = builtin->builtin_character;
 535     lai->primitive_type_vector [f_primitive_type_logical]
 536       = builtin->builtin_logical;
 537     lai->primitive_type_vector [f_primitive_type_logical_s1]
 538       = builtin->builtin_logical_s1;
 539     lai->primitive_type_vector [f_primitive_type_logical_s2]
 540       = builtin->builtin_logical_s2;
 541     lai->primitive_type_vector [f_primitive_type_logical_s8]
 542       = builtin->builtin_logical_s8;
 543     lai->primitive_type_vector [f_primitive_type_real]
 544       = builtin->builtin_real;
 545     lai->primitive_type_vector [f_primitive_type_real_s8]
 546       = builtin->builtin_real_s8;
 547     lai->primitive_type_vector [f_primitive_type_real_s16]
 548       = builtin->builtin_real_s16;
 549     lai->primitive_type_vector [f_primitive_type_complex_s8]
 550       = builtin->builtin_complex_s8;
 551     lai->primitive_type_vector [f_primitive_type_complex_s16]
 552       = builtin->builtin_complex_s16;
 553     lai->primitive_type_vector [f_primitive_type_void]
 554       = builtin->builtin_void;
 555
 556     lai->bool_type_symbol = "logical";
 557     lai->bool_type_default = builtin->builtin_logical_s2;
 558   }
 559
 560   /* See language.h.  */
 561   unsigned int search_name_hash (const char *name) const override
 562   {
 563     return cp_search_name_hash (name);
 564   }
 565
 566   /* See language.h.  */
 567
 568   char *demangle (const char *mangled, int options) const override
 569   {
 570       /* We could support demangling here to provide module namespaces
 571          also for inferiors with only minimal symbol table (ELF symbols).
 572          Just the mangling standard is not standardized across compilers
 573          and there is no DW_AT_producer available for inferiors with only
 574          the ELF symbols to check the mangling kind.  */
 575     return nullptr;
 576   }
 577
 578   /* See language.h.  */
 579
 580   void print_type (struct type *type, const char *varstring,
 581                    struct ui_file *stream, int show, int level,
 582                    const struct type_print_options *flags) const override
 583   {
 584     f_print_type (type, varstring, stream, show, level, flags);
 585   }
 586
 587   /* See language.h.  This just returns default set of word break
 588      characters but with the modules separator `::' removed.  */
 589
 590   const char *word_break_characters (void) const override
 591   {
 592     static char *retval;
 593
 594     if (!retval)
 595       {
 596         char *s;
 597
 598         retval = xstrdup (language_defn::word_break_characters ());
 599         s = strchr (retval, ':');
 600         if (s)
 601           {
 602             char *last_char = &s[strlen (s) - 1];
 603
 604             *s = *last_char;
 605             *last_char = 0;
 606           }
 607       }
 608     return retval;
 609   }
 610
 611
 612   /* See language.h.  */
 613
 614   void collect_symbol_completion_matches (completion_tracker &tracker,
 615                                           complete_symbol_mode mode,
 616                                           symbol_name_match_type name_match_type,
 617                                           const char *text, const char *word,
 618                                           enum type_code code) const override
 619   {
 620     /* Consider the modules separator :: as a valid symbol name character
 621        class.  */
 622     default_collect_symbol_completion_matches_break_on (tracker, mode,
 623                                                         name_match_type,
 624                                                         text, word, ":",
 625                                                         code);
 626   }
 627
 628   /* See language.h.  */
 629
 630   void value_print_inner
 631         (struct value *val, struct ui_file *stream, int recurse,
 632          const struct value_print_options *options) const override
 633   {
 634     return f_value_print_inner (val, stream, recurse, options);
 635   }
 636
 637   /* See language.h.  */
 638
 639   struct block_symbol lookup_symbol_nonlocal
 640         (const char *name, const struct block *block,
 641          const domain_enum domain) const override
 642   {
 643     return cp_lookup_symbol_nonlocal (this, name, block, domain);
 644   }
 645
 646   /* See language.h.  */
 647
 648   int parser (struct parser_state *ps) const override
 649   {
 650     return f_parse (ps);
 651   }
 652
 653   /* See language.h.  */
 654
 655   void emitchar (int ch, struct type *chtype,
 656                  struct ui_file *stream, int quoter) const override
 657   {
 658     const char *encoding = f_get_encoding (chtype);
 659     generic_emit_char (ch, chtype, stream, quoter, encoding);
 660   }
 661
 662   /* See language.h.  */
 663
 664   void printchar (int ch, struct type *chtype,
 665                   struct ui_file *stream) const override
 666   {
 667     fputs_filtered ("'", stream);
 668     LA_EMIT_CHAR (ch, chtype, stream, '\'');
 669     fputs_filtered ("'", stream);
 670   }
 671
 672   /* See language.h.  */
 673
 674   void printstr (struct ui_file *stream, struct type *elttype,
 675                  const gdb_byte *string, unsigned int length,
 676                  const char *encoding, int force_ellipses,
 677                  const struct value_print_options *options) const override
 678   {
 679     const char *type_encoding = f_get_encoding (elttype);
 680
 681     if (TYPE_LENGTH (elttype) == 4)
 682       fputs_filtered ("4_", stream);
 683
 684     if (!encoding || !*encoding)
 685       encoding = type_encoding;
 686
 687     generic_printstr (stream, elttype, string, length, encoding,
 688                       force_ellipses, '\'', 0, options);
 689   }
 690
 691   /* See language.h.  */
 692
 693   void print_typedef (struct type *type, struct symbol *new_symbol,
 694                       struct ui_file *stream) const override
 695   {
 696     f_print_typedef (type, new_symbol, stream);
 697   }
 698
 699   /* See language.h.  */
 700
 701   bool is_string_type_p (struct type *type) const override
 702   {
 703     type = check_typedef (type);
 704     return (type->code () == TYPE_CODE_STRING
 705             || (type->code () == TYPE_CODE_ARRAY
 706                 && TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_CHAR));
 707   }
 708
 709   /* See language.h.  */
 710
 711   const char *struct_too_deep_ellipsis () const override
 712   { return "(...)"; }
 713
 714   /* See language.h.  */
 715
 716   bool c_style_arrays_p () const override
 717   { return false; }
 718
 719   /* See language.h.  */
 720
 721   bool range_checking_on_by_default () const override
 722   { return true; }
 723
 724   /* See language.h.  */
 725
 726   enum case_sensitivity case_sensitivity () const override
 727   { return case_sensitive_off; }
 728
 729   /* See language.h.  */
 730
 731   enum array_ordering array_ordering () const override
 732   { return array_column_major; }
 733
 734   /* See language.h.  */
 735
 736   const struct exp_descriptor *expression_ops () const override
 737   { return &exp_descriptor_f; }
 738
 739 protected:
 740
 741   /* See language.h.  */
 742
 743   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
 744         (const lookup_name_info &lookup_name) const override
 745   {
 746     return cp_get_symbol_name_matcher (lookup_name);
 747   }
 748 };
 749
 750 /* Single instance of the Fortran language class.  */
 751
 752 static f_language f_language_defn;
 753
 754 static void *
 755 build_fortran_types (struct gdbarch *gdbarch)
 756 {
 757   struct builtin_f_type *builtin_f_type
 758     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 759
 760   builtin_f_type->builtin_void
 761     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
 762
 763   builtin_f_type->builtin_character
 764     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 765
 766   builtin_f_type->builtin_logical_s1
 767     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 768
 769   builtin_f_type->builtin_integer_s2
 770     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 771                          "integer*2");
 772
 773   builtin_f_type->builtin_integer_s8
 774     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 775                          "integer*8");
 776
 777   builtin_f_type->builtin_logical_s2
 778     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 779                          "logical*2");
 780
 781   builtin_f_type->builtin_logical_s8
 782     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 783                          "logical*8");
 784
 785   builtin_f_type->builtin_integer
 786     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 787                          "integer");
 788
 789   builtin_f_type->builtin_logical
 790     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 791                          "logical*4");
 792
 793   builtin_f_type->builtin_real
 794     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 795                        "real", gdbarch_float_format (gdbarch));
 796   builtin_f_type->builtin_real_s8
 797     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 798                        "real*8", gdbarch_double_format (gdbarch));
 799   auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
 800   if (fmt != nullptr)
 801     builtin_f_type->builtin_real_s16
 802       = arch_float_type (gdbarch, 128, "real*16", fmt);
 803   else if (gdbarch_long_double_bit (gdbarch) == 128)
 804     builtin_f_type->builtin_real_s16
 805       = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 806                          "real*16", gdbarch_long_double_format (gdbarch));
 807   else
 808     builtin_f_type->builtin_real_s16
 809       = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
 810
 811   builtin_f_type->builtin_complex_s8
 812     = init_complex_type ("complex*8", builtin_f_type->builtin_real);
 813   builtin_f_type->builtin_complex_s16
 814     = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
 815
 816   if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
 817     builtin_f_type->builtin_complex_s32
 818       = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
 819   else
 820     builtin_f_type->builtin_complex_s32
 821       = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
 822
 823   return builtin_f_type;
 824 }
 825
 826 static struct gdbarch_data *f_type_data;
 827
 828 const struct builtin_f_type *
 829 builtin_f_type (struct gdbarch *gdbarch)
 830 {
 831   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 832 }
 833
 834 void _initialize_f_language ();
 835 void
 836 _initialize_f_language ()
 837 {
 838   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 839 }
 840
 841 /* See f-lang.h.  */
 842
 843 struct value *
 844 fortran_argument_convert (struct value *value, bool is_artificial)
 845 {
 846   if (!is_artificial)
 847     {
 848       /* If the value is not in the inferior e.g. registers values,
 849          convenience variables and user input.  */
 850       if (VALUE_LVAL (value) != lval_memory)
 851         {
 852           struct type *type = value_type (value);
 853           const int length = TYPE_LENGTH (type);
 854           const CORE_ADDR addr
 855             = value_as_long (value_allocate_space_in_inferior (length));
 856           write_memory (addr, value_contents (value), length);
 857           struct value *val
 858             = value_from_contents_and_address (type, value_contents (value),
 859                                                addr);
 860           return value_addr (val);
 861         }
 862       else
 863         return value_addr (value); /* Program variables, e.g. arrays.  */
 864     }
 865     return value;
 866 }
 867
 868 /* See f-lang.h.  */
 869
 870 struct type *
 871 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 872 {
 873   if (value_type (arg)->code () == TYPE_CODE_PTR)
 874     return value_type (arg);
 875   return type;
 876 }