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