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_type,                 /* Print a type using appropriate syntax */
 612   f_print_typedef,              /* Print a typedef using appropriate syntax */
 613   f_value_print_innner,         /* la_value_print_inner */
 614   c_value_print,                /* FIXME */
 615   NULL,                         /* Language specific skip_trampoline */
 616   NULL,                         /* name_of_this */
 617   false,                        /* la_store_sym_names_in_linkage_form_p */
 618   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 619
 620   /* We could support demangling here to provide module namespaces
 621      also for inferiors with only minimal symbol table (ELF symbols).
 622      Just the mangling standard is not standardized across compilers
 623      and there is no DW_AT_producer available for inferiors with only
 624      the ELF symbols to check the mangling kind.  */
 625   NULL,                         /* Language specific symbol demangler */
 626   NULL,
 627   NULL,                         /* Language specific
 628                                    class_name_from_physname */
 629   f_op_print_tab,               /* expression operators for printing */
 630   0,                            /* arrays are first-class (not c-style) */
 631   1,                            /* String lower bound */
 632   f_word_break_characters,
 633   f_collect_symbol_completion_matches,
 634   c_watch_location_expression,
 635   cp_get_symbol_name_matcher,   /* la_get_symbol_name_matcher */
 636   cp_search_name_hash,
 637   &default_varobj_ops,
 638   NULL,
 639   f_is_string_type_p,
 640   "(...)"                       /* la_struct_too_deep_ellipsis */
 641 };
 642
 643 /* Class representing the Fortran language.  */
 644
 645 class f_language : public language_defn
 646 {
 647 public:
 648   f_language ()
 649     : language_defn (language_fortran, f_language_data)
 650   { /* Nothing.  */ }
 651
 652   /* See language.h.  */
 653   void language_arch_info (struct gdbarch *gdbarch,
 654                            struct language_arch_info *lai) const override
 655   {
 656     const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
 657
 658     lai->string_char_type = builtin->builtin_character;
 659     lai->primitive_type_vector
 660       = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
 661                                 struct type *);
 662
 663     lai->primitive_type_vector [f_primitive_type_character]
 664       = builtin->builtin_character;
 665     lai->primitive_type_vector [f_primitive_type_logical]
 666       = builtin->builtin_logical;
 667     lai->primitive_type_vector [f_primitive_type_logical_s1]
 668       = builtin->builtin_logical_s1;
 669     lai->primitive_type_vector [f_primitive_type_logical_s2]
 670       = builtin->builtin_logical_s2;
 671     lai->primitive_type_vector [f_primitive_type_logical_s8]
 672       = builtin->builtin_logical_s8;
 673     lai->primitive_type_vector [f_primitive_type_real]
 674       = builtin->builtin_real;
 675     lai->primitive_type_vector [f_primitive_type_real_s8]
 676       = builtin->builtin_real_s8;
 677     lai->primitive_type_vector [f_primitive_type_real_s16]
 678       = builtin->builtin_real_s16;
 679     lai->primitive_type_vector [f_primitive_type_complex_s8]
 680       = builtin->builtin_complex_s8;
 681     lai->primitive_type_vector [f_primitive_type_complex_s16]
 682       = builtin->builtin_complex_s16;
 683     lai->primitive_type_vector [f_primitive_type_void]
 684       = builtin->builtin_void;
 685
 686     lai->bool_type_symbol = "logical";
 687     lai->bool_type_default = builtin->builtin_logical_s2;
 688   }
 689 };
 690
 691 /* Single instance of the Fortran language class.  */
 692
 693 static f_language f_language_defn;
 694
 695 static void *
 696 build_fortran_types (struct gdbarch *gdbarch)
 697 {
 698   struct builtin_f_type *builtin_f_type
 699     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 700
 701   builtin_f_type->builtin_void
 702     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
 703
 704   builtin_f_type->builtin_character
 705     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 706
 707   builtin_f_type->builtin_logical_s1
 708     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 709
 710   builtin_f_type->builtin_integer_s2
 711     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 712                          "integer*2");
 713
 714   builtin_f_type->builtin_integer_s8
 715     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 716                          "integer*8");
 717
 718   builtin_f_type->builtin_logical_s2
 719     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 720                          "logical*2");
 721
 722   builtin_f_type->builtin_logical_s8
 723     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 724                          "logical*8");
 725
 726   builtin_f_type->builtin_integer
 727     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 728                          "integer");
 729
 730   builtin_f_type->builtin_logical
 731     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 732                          "logical*4");
 733
 734   builtin_f_type->builtin_real
 735     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 736                        "real", gdbarch_float_format (gdbarch));
 737   builtin_f_type->builtin_real_s8
 738     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 739                        "real*8", gdbarch_double_format (gdbarch));
 740   auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
 741   if (fmt != nullptr)
 742     builtin_f_type->builtin_real_s16
 743       = arch_float_type (gdbarch, 128, "real*16", fmt);
 744   else if (gdbarch_long_double_bit (gdbarch) == 128)
 745     builtin_f_type->builtin_real_s16
 746       = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 747                          "real*16", gdbarch_long_double_format (gdbarch));
 748   else
 749     builtin_f_type->builtin_real_s16
 750       = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
 751
 752   builtin_f_type->builtin_complex_s8
 753     = init_complex_type ("complex*8", builtin_f_type->builtin_real);
 754   builtin_f_type->builtin_complex_s16
 755     = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
 756
 757   if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
 758     builtin_f_type->builtin_complex_s32
 759       = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
 760   else
 761     builtin_f_type->builtin_complex_s32
 762       = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
 763
 764   return builtin_f_type;
 765 }
 766
 767 static struct gdbarch_data *f_type_data;
 768
 769 const struct builtin_f_type *
 770 builtin_f_type (struct gdbarch *gdbarch)
 771 {
 772   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 773 }
 774
 775 void _initialize_f_language ();
 776 void
 777 _initialize_f_language ()
 778 {
 779   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 780 }
 781
 782 /* See f-lang.h.  */
 783
 784 struct value *
 785 fortran_argument_convert (struct value *value, bool is_artificial)
 786 {
 787   if (!is_artificial)
 788     {
 789       /* If the value is not in the inferior e.g. registers values,
 790          convenience variables and user input.  */
 791       if (VALUE_LVAL (value) != lval_memory)
 792         {
 793           struct type *type = value_type (value);
 794           const int length = TYPE_LENGTH (type);
 795           const CORE_ADDR addr
 796             = value_as_long (value_allocate_space_in_inferior (length));
 797           write_memory (addr, value_contents (value), length);
 798           struct value *val
 799             = value_from_contents_and_address (type, value_contents (value),
 800                                                addr);
 801           return value_addr (val);
 802         }
 803       else
 804         return value_addr (value); /* Program variables, e.g. arrays.  */
 805     }
 806     return value;
 807 }
 808
 809 /* See f-lang.h.  */
 810
 811 struct type *
 812 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 813 {
 814   if (value_type (arg)->code () == TYPE_CODE_PTR)
 815     return value_type (arg);
 816   return type;
 817 }