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