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