gdb/f-lang.c

   1 /* Fortran language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-2020 Free Software Foundation, Inc.
   4
   5    Contributed by Motorola.  Adapted from the C parser by Farooq Butt
   6    (fmbutt@engage.sps.mot.com).
   7
   8    This file is part of GDB.
   9
  10    This program is free software; you can redistribute it and/or modify
  11    it under the terms of the GNU General Public License as published by
  12    the Free Software Foundation; either version 3 of the License, or
  13    (at your option) any later version.
  14
  15    This program is distributed in the hope that it will be useful,
  16    but WITHOUT ANY WARRANTY; without even the implied warranty of
  17    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18    GNU General Public License for more details.
  19
  20    You should have received a copy of the GNU General Public License
  21    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  22
  23 #include "defs.h"
  24 #include "symtab.h"
  25 #include "gdbtypes.h"
  26 #include "expression.h"
  27 #include "parser-defs.h"
  28 #include "language.h"
  29 #include "varobj.h"
  30 #include "gdbcore.h"
  31 #include "f-lang.h"
  32 #include "valprint.h"
  33 #include "value.h"
  34 #include "cp-support.h"
  35 #include "charset.h"
  36 #include "c-lang.h"
  37 #include "target-float.h"
  38 #include "gdbarch.h"
  39
  40 #include <math.h>
  41
  42 /* Local functions */
  43
  44 /* Return the encoding that should be used for the character type
  45    TYPE.  */
  46
  47 const char *
  48 f_language::get_encoding (struct type *type)
  49 {
  50   const char *encoding;
  51
  52   switch (TYPE_LENGTH (type))
  53     {
  54     case 1:
  55       encoding = target_charset (get_type_arch (type));
  56       break;
  57     case 4:
  58       if (type_byte_order (type) == BFD_ENDIAN_BIG)
  59         encoding = "UTF-32BE";
  60       else
  61         encoding = "UTF-32LE";
  62       break;
  63
  64     default:
  65       error (_("unrecognized character type"));
  66     }
  67
  68   return encoding;
  69 }
  70
  71 \f
  72
  73 /* Table of operators and their precedences for printing expressions.  */
  74
  75 const struct op_print f_language::op_print_tab[] =
  76 {
  77   {"+", BINOP_ADD, PREC_ADD, 0},
  78   {"+", UNOP_PLUS, PREC_PREFIX, 0},
  79   {"-", BINOP_SUB, PREC_ADD, 0},
  80   {"-", UNOP_NEG, PREC_PREFIX, 0},
  81   {"*", BINOP_MUL, PREC_MUL, 0},
  82   {"/", BINOP_DIV, PREC_MUL, 0},
  83   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
  84   {"MOD", BINOP_REM, PREC_MUL, 0},
  85   {"=", BINOP_ASSIGN, PREC_ASSIGN, 1},
  86   {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
  87   {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
  88   {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
  89   {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0},
  90   {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0},
  91   {".LE.", BINOP_LEQ, PREC_ORDER, 0},
  92   {".GE.", BINOP_GEQ, PREC_ORDER, 0},
  93   {".GT.", BINOP_GTR, PREC_ORDER, 0},
  94   {".LT.", BINOP_LESS, PREC_ORDER, 0},
  95   {"**", UNOP_IND, PREC_PREFIX, 0},
  96   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
  97   {NULL, OP_NULL, PREC_REPEAT, 0}
  98 };
  99 \f
 100 enum f_primitive_types {
 101   f_primitive_type_character,
 102   f_primitive_type_logical,
 103   f_primitive_type_logical_s1,
 104   f_primitive_type_logical_s2,
 105   f_primitive_type_logical_s8,
 106   f_primitive_type_integer,
 107   f_primitive_type_integer_s2,
 108   f_primitive_type_real,
 109   f_primitive_type_real_s8,
 110   f_primitive_type_real_s16,
 111   f_primitive_type_complex_s8,
 112   f_primitive_type_complex_s16,
 113   f_primitive_type_void,
 114   nr_f_primitive_types
 115 };
 116
 117 /* Called from fortran_value_subarray to take a slice of an array or a
 118    string.  ARRAY is the array or string to be accessed.  EXP, POS, and
 119    NOSIDE are as for evaluate_subexp_standard.  Return a value that is a
 120    slice of the array.  */
 121
 122 static struct value *
 123 value_f90_subarray (struct value *array,
 124                     struct expression *exp, int *pos, enum noside noside)
 125 {
 126   int pc = (*pos) + 1;
 127   LONGEST low_bound, high_bound, stride;
 128   struct type *range = check_typedef (value_type (array)->index_type ());
 129   enum range_flag range_flag
 130     = (enum range_flag) longest_to_int (exp->elts[pc].longconst);
 131
 132   *pos += 3;
 133
 134   if (range_flag & RANGE_LOW_BOUND_DEFAULT)
 135     low_bound = range->bounds ()->low.const_val ();
 136   else
 137     low_bound = value_as_long (evaluate_subexp (nullptr, exp, pos, noside));
 138
 139   if (range_flag & RANGE_HIGH_BOUND_DEFAULT)
 140     high_bound = range->bounds ()->high.const_val ();
 141   else
 142     high_bound = value_as_long (evaluate_subexp (nullptr, exp, pos, noside));
 143
 144   if (range_flag & RANGE_HAS_STRIDE)
 145     stride = value_as_long (evaluate_subexp (nullptr, exp, pos, noside));
 146   else
 147     stride = 1;
 148
 149   if (stride != 1)
 150     error (_("Fortran array strides are not currently supported"));
 151
 152   return value_slice (array, low_bound, high_bound - low_bound + 1);
 153 }
 154
 155 /* Helper for skipping all the arguments in an undetermined argument list.
 156    This function was designed for use in the OP_F77_UNDETERMINED_ARGLIST
 157    case of evaluate_subexp_standard as multiple, but not all, code paths
 158    require a generic skip.  */
 159
 160 static void
 161 skip_undetermined_arglist (int nargs, struct expression *exp, int *pos,
 162                            enum noside noside)
 163 {
 164   for (int i = 0; i < nargs; ++i)
 165     evaluate_subexp (nullptr, exp, pos, noside);
 166 }
 167
 168 /* Return the number of dimensions for a Fortran array or string.  */
 169
 170 int
 171 calc_f77_array_dims (struct type *array_type)
 172 {
 173   int ndimen = 1;
 174   struct type *tmp_type;
 175
 176   if ((array_type->code () == TYPE_CODE_STRING))
 177     return 1;
 178
 179   if ((array_type->code () != TYPE_CODE_ARRAY))
 180     error (_("Can't get dimensions for a non-array type"));
 181
 182   tmp_type = array_type;
 183
 184   while ((tmp_type = TYPE_TARGET_TYPE (tmp_type)))
 185     {
 186       if (tmp_type->code () == TYPE_CODE_ARRAY)
 187         ++ndimen;
 188     }
 189   return ndimen;
 190 }
 191
 192 /* Called from evaluate_subexp_standard to perform array indexing, and
 193    sub-range extraction, for Fortran.  As well as arrays this function
 194    also handles strings as they can be treated like arrays of characters.
 195    ARRAY is the array or string being accessed.  EXP, POS, and NOSIDE are
 196    as for evaluate_subexp_standard, and NARGS is the number of arguments
 197    in this access (e.g. 'array (1,2,3)' would be NARGS 3).  */
 198
 199 static struct value *
 200 fortran_value_subarray (struct value *array, struct expression *exp,
 201                         int *pos, int nargs, enum noside noside)
 202 {
 203   if (exp->elts[*pos].opcode == OP_RANGE)
 204     return value_f90_subarray (array, exp, pos, noside);
 205
 206   if (noside == EVAL_SKIP)
 207     {
 208       skip_undetermined_arglist (nargs, exp, pos, noside);
 209       /* Return the dummy value with the correct type.  */
 210       return array;
 211     }
 212
 213   LONGEST subscript_array[MAX_FORTRAN_DIMS];
 214   int ndimensions = 1;
 215   struct type *type = check_typedef (value_type (array));
 216
 217   if (nargs > MAX_FORTRAN_DIMS)
 218     error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS);
 219
 220   ndimensions = calc_f77_array_dims (type);
 221
 222   if (nargs != ndimensions)
 223     error (_("Wrong number of subscripts"));
 224
 225   gdb_assert (nargs > 0);
 226
 227   /* Now that we know we have a legal array subscript expression let us
 228      actually find out where this element exists in the array.  */
 229
 230   /* Take array indices left to right.  */
 231   for (int i = 0; i < nargs; i++)
 232     {
 233       /* Evaluate each subscript; it must be a legal integer in F77.  */
 234       value *arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 235
 236       /* Fill in the subscript array.  */
 237       subscript_array[i] = value_as_long (arg2);
 238     }
 239
 240   /* Internal type of array is arranged right to left.  */
 241   for (int i = nargs; i > 0; i--)
 242     {
 243       struct type *array_type = check_typedef (value_type (array));
 244       LONGEST index = subscript_array[i - 1];
 245
 246       array = value_subscripted_rvalue (array, index,
 247                                         f77_get_lowerbound (array_type));
 248     }
 249
 250   return array;
 251 }
 252
 253 /* Special expression evaluation cases for Fortran.  */
 254
 255 static struct value *
 256 evaluate_subexp_f (struct type *expect_type, struct expression *exp,
 257                    int *pos, enum noside noside)
 258 {
 259   struct value *arg1 = NULL, *arg2 = NULL;
 260   enum exp_opcode op;
 261   int pc;
 262   struct type *type;
 263
 264   pc = *pos;
 265   *pos += 1;
 266   op = exp->elts[pc].opcode;
 267
 268   switch (op)
 269     {
 270     default:
 271       *pos -= 1;
 272       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 273
 274     case UNOP_ABS:
 275       arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 276       if (noside == EVAL_SKIP)
 277         return eval_skip_value (exp);
 278       type = value_type (arg1);
 279       switch (type->code ())
 280         {
 281         case TYPE_CODE_FLT:
 282           {
 283             double d
 284               = fabs (target_float_to_host_double (value_contents (arg1),
 285                                                    value_type (arg1)));
 286             return value_from_host_double (type, d);
 287           }
 288         case TYPE_CODE_INT:
 289           {
 290             LONGEST l = value_as_long (arg1);
 291             l = llabs (l);
 292             return value_from_longest (type, l);
 293           }
 294         }
 295       error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
 296
 297     case BINOP_MOD:
 298       arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 299       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 300       if (noside == EVAL_SKIP)
 301         return eval_skip_value (exp);
 302       type = value_type (arg1);
 303       if (type->code () != value_type (arg2)->code ())
 304         error (_("non-matching types for parameters to MOD ()"));
 305       switch (type->code ())
 306         {
 307         case TYPE_CODE_FLT:
 308           {
 309             double d1
 310               = target_float_to_host_double (value_contents (arg1),
 311                                              value_type (arg1));
 312             double d2
 313               = target_float_to_host_double (value_contents (arg2),
 314                                              value_type (arg2));
 315             double d3 = fmod (d1, d2);
 316             return value_from_host_double (type, d3);
 317           }
 318         case TYPE_CODE_INT:
 319           {
 320             LONGEST v1 = value_as_long (arg1);
 321             LONGEST v2 = value_as_long (arg2);
 322             if (v2 == 0)
 323               error (_("calling MOD (N, 0) is undefined"));
 324             LONGEST v3 = v1 - (v1 / v2) * v2;
 325             return value_from_longest (value_type (arg1), v3);
 326           }
 327         }
 328       error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
 329
 330     case UNOP_FORTRAN_CEILING:
 331       {
 332         arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 333         if (noside == EVAL_SKIP)
 334           return eval_skip_value (exp);
 335         type = value_type (arg1);
 336         if (type->code () != TYPE_CODE_FLT)
 337           error (_("argument to CEILING must be of type float"));
 338         double val
 339           = target_float_to_host_double (value_contents (arg1),
 340                                          value_type (arg1));
 341         val = ceil (val);
 342         return value_from_host_double (type, val);
 343       }
 344
 345     case UNOP_FORTRAN_FLOOR:
 346       {
 347         arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 348         if (noside == EVAL_SKIP)
 349           return eval_skip_value (exp);
 350         type = value_type (arg1);
 351         if (type->code () != TYPE_CODE_FLT)
 352           error (_("argument to FLOOR must be of type float"));
 353         double val
 354           = target_float_to_host_double (value_contents (arg1),
 355                                          value_type (arg1));
 356         val = floor (val);
 357         return value_from_host_double (type, val);
 358       }
 359
 360     case BINOP_FORTRAN_MODULO:
 361       {
 362         arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 363         arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 364         if (noside == EVAL_SKIP)
 365           return eval_skip_value (exp);
 366         type = value_type (arg1);
 367         if (type->code () != value_type (arg2)->code ())
 368           error (_("non-matching types for parameters to MODULO ()"));
 369         /* MODULO(A, P) = A - FLOOR (A / P) * P */
 370         switch (type->code ())
 371           {
 372           case TYPE_CODE_INT:
 373             {
 374               LONGEST a = value_as_long (arg1);
 375               LONGEST p = value_as_long (arg2);
 376               LONGEST result = a - (a / p) * p;
 377               if (result != 0 && (a < 0) != (p < 0))
 378                 result += p;
 379               return value_from_longest (value_type (arg1), result);
 380             }
 381           case TYPE_CODE_FLT:
 382             {
 383               double a
 384                 = target_float_to_host_double (value_contents (arg1),
 385                                                value_type (arg1));
 386               double p
 387                 = target_float_to_host_double (value_contents (arg2),
 388                                                value_type (arg2));
 389               double result = fmod (a, p);
 390               if (result != 0 && (a < 0.0) != (p < 0.0))
 391                 result += p;
 392               return value_from_host_double (type, result);
 393             }
 394           }
 395         error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
 396       }
 397
 398     case BINOP_FORTRAN_CMPLX:
 399       arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 400       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 401       if (noside == EVAL_SKIP)
 402         return eval_skip_value (exp);
 403       type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
 404       return value_literal_complex (arg1, arg2, type);
 405
 406     case UNOP_FORTRAN_KIND:
 407       arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
 408       type = value_type (arg1);
 409
 410       switch (type->code ())
 411         {
 412           case TYPE_CODE_STRUCT:
 413           case TYPE_CODE_UNION:
 414           case TYPE_CODE_MODULE:
 415           case TYPE_CODE_FUNC:
 416             error (_("argument to kind must be an intrinsic type"));
 417         }
 418
 419       if (!TYPE_TARGET_TYPE (type))
 420         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 421                                    TYPE_LENGTH (type));
 422       return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 423                                  TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
 424
 425
 426     case OP_F77_UNDETERMINED_ARGLIST:
 427       /* Remember that in F77, functions, substring ops and array subscript
 428          operations cannot be disambiguated at parse time.  We have made
 429          all array subscript operations, substring operations as well as
 430          function calls come here and we now have to discover what the heck
 431          this thing actually was.  If it is a function, we process just as
 432          if we got an OP_FUNCALL.  */
 433       int nargs = longest_to_int (exp->elts[pc + 1].longconst);
 434       (*pos) += 2;
 435
 436       /* First determine the type code we are dealing with.  */
 437       arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 438       type = check_typedef (value_type (arg1));
 439       enum type_code code = type->code ();
 440
 441       if (code == TYPE_CODE_PTR)
 442         {
 443           /* Fortran always passes variable to subroutines as pointer.
 444              So we need to look into its target type to see if it is
 445              array, string or function.  If it is, we need to switch
 446              to the target value the original one points to.  */
 447           struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
 448
 449           if (target_type->code () == TYPE_CODE_ARRAY
 450               || target_type->code () == TYPE_CODE_STRING
 451               || target_type->code () == TYPE_CODE_FUNC)
 452             {
 453               arg1 = value_ind (arg1);
 454               type = check_typedef (value_type (arg1));
 455               code = type->code ();
 456             }
 457         }
 458
 459       switch (code)
 460         {
 461         case TYPE_CODE_ARRAY:
 462         case TYPE_CODE_STRING:
 463           return fortran_value_subarray (arg1, exp, pos, nargs, noside);
 464
 465         case TYPE_CODE_PTR:
 466         case TYPE_CODE_FUNC:
 467         case TYPE_CODE_INTERNAL_FUNCTION:
 468           {
 469             /* It's a function call.  Allocate arg vector, including
 470             space for the function to be called in argvec[0] and a
 471             termination NULL.  */
 472             struct value **argvec = (struct value **)
 473               alloca (sizeof (struct value *) * (nargs + 2));
 474             argvec[0] = arg1;
 475             int tem = 1;
 476             for (; tem <= nargs; tem++)
 477               {
 478                 argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
 479                 /* Arguments in Fortran are passed by address.  Coerce the
 480                    arguments here rather than in value_arg_coerce as
 481                    otherwise the call to malloc to place the non-lvalue
 482                    parameters in target memory is hit by this Fortran
 483                    specific logic.  This results in malloc being called
 484                    with a pointer to an integer followed by an attempt to
 485                    malloc the arguments to malloc in target memory.
 486                    Infinite recursion ensues.  */
 487                 if (code == TYPE_CODE_PTR || code == TYPE_CODE_FUNC)
 488                   {
 489                     bool is_artificial
 490                       = TYPE_FIELD_ARTIFICIAL (value_type (arg1), tem - 1);
 491                     argvec[tem] = fortran_argument_convert (argvec[tem],
 492                                                             is_artificial);
 493                   }
 494               }
 495             argvec[tem] = 0;    /* signal end of arglist */
 496             if (noside == EVAL_SKIP)
 497               return eval_skip_value (exp);
 498             return evaluate_subexp_do_call (exp, noside, nargs, argvec, NULL,
 499                                             expect_type);
 500           }
 501
 502         default:
 503           error (_("Cannot perform substring on this type"));
 504         }
 505     }
 506
 507   /* Should be unreachable.  */
 508   return nullptr;
 509 }
 510
 511 /* Special expression lengths for Fortran.  */
 512
 513 static void
 514 operator_length_f (const struct expression *exp, int pc, int *oplenp,
 515                    int *argsp)
 516 {
 517   int oplen = 1;
 518   int args = 0;
 519
 520   switch (exp->elts[pc - 1].opcode)
 521     {
 522     default:
 523       operator_length_standard (exp, pc, oplenp, argsp);
 524       return;
 525
 526     case UNOP_FORTRAN_KIND:
 527     case UNOP_FORTRAN_FLOOR:
 528     case UNOP_FORTRAN_CEILING:
 529       oplen = 1;
 530       args = 1;
 531       break;
 532
 533     case BINOP_FORTRAN_CMPLX:
 534     case BINOP_FORTRAN_MODULO:
 535       oplen = 1;
 536       args = 2;
 537       break;
 538
 539     case OP_F77_UNDETERMINED_ARGLIST:
 540       oplen = 3;
 541       args = 1 + longest_to_int (exp->elts[pc - 2].longconst);
 542       break;
 543     }
 544
 545   *oplenp = oplen;
 546   *argsp = args;
 547 }
 548
 549 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 550    the extra argument NAME which is the text that should be printed as the
 551    name of this operation.  */
 552
 553 static void
 554 print_unop_subexp_f (struct expression *exp, int *pos,
 555                      struct ui_file *stream, enum precedence prec,
 556                      const char *name)
 557 {
 558   (*pos)++;
 559   fprintf_filtered (stream, "%s(", name);
 560   print_subexp (exp, pos, stream, PREC_SUFFIX);
 561   fputs_filtered (")", stream);
 562 }
 563
 564 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 565    the extra argument NAME which is the text that should be printed as the
 566    name of this operation.  */
 567
 568 static void
 569 print_binop_subexp_f (struct expression *exp, int *pos,
 570                       struct ui_file *stream, enum precedence prec,
 571                       const char *name)
 572 {
 573   (*pos)++;
 574   fprintf_filtered (stream, "%s(", name);
 575   print_subexp (exp, pos, stream, PREC_SUFFIX);
 576   fputs_filtered (",", stream);
 577   print_subexp (exp, pos, stream, PREC_SUFFIX);
 578   fputs_filtered (")", stream);
 579 }
 580
 581 /* Special expression printing for Fortran.  */
 582
 583 static void
 584 print_subexp_f (struct expression *exp, int *pos,
 585                 struct ui_file *stream, enum precedence prec)
 586 {
 587   int pc = *pos;
 588   enum exp_opcode op = exp->elts[pc].opcode;
 589
 590   switch (op)
 591     {
 592     default:
 593       print_subexp_standard (exp, pos, stream, prec);
 594       return;
 595
 596     case UNOP_FORTRAN_KIND:
 597       print_unop_subexp_f (exp, pos, stream, prec, "KIND");
 598       return;
 599
 600     case UNOP_FORTRAN_FLOOR:
 601       print_unop_subexp_f (exp, pos, stream, prec, "FLOOR");
 602       return;
 603
 604     case UNOP_FORTRAN_CEILING:
 605       print_unop_subexp_f (exp, pos, stream, prec, "CEILING");
 606       return;
 607
 608     case BINOP_FORTRAN_CMPLX:
 609       print_binop_subexp_f (exp, pos, stream, prec, "CMPLX");
 610       return;
 611
 612     case BINOP_FORTRAN_MODULO:
 613       print_binop_subexp_f (exp, pos, stream, prec, "MODULO");
 614       return;
 615
 616     case OP_F77_UNDETERMINED_ARGLIST:
 617       print_subexp_funcall (exp, pos, stream);
 618       return;
 619     }
 620 }
 621
 622 /* Special expression names for Fortran.  */
 623
 624 static const char *
 625 op_name_f (enum exp_opcode opcode)
 626 {
 627   switch (opcode)
 628     {
 629     default:
 630       return op_name_standard (opcode);
 631
 632 #define OP(name)        \
 633     case name:          \
 634       return #name ;
 635 #include "fortran-operator.def"
 636 #undef OP
 637     }
 638 }
 639
 640 /* Special expression dumping for Fortran.  */
 641
 642 static int
 643 dump_subexp_body_f (struct expression *exp,
 644                     struct ui_file *stream, int elt)
 645 {
 646   int opcode = exp->elts[elt].opcode;
 647   int oplen, nargs, i;
 648
 649   switch (opcode)
 650     {
 651     default:
 652       return dump_subexp_body_standard (exp, stream, elt);
 653
 654     case UNOP_FORTRAN_KIND:
 655     case UNOP_FORTRAN_FLOOR:
 656     case UNOP_FORTRAN_CEILING:
 657     case BINOP_FORTRAN_CMPLX:
 658     case BINOP_FORTRAN_MODULO:
 659       operator_length_f (exp, (elt + 1), &oplen, &nargs);
 660       break;
 661
 662     case OP_F77_UNDETERMINED_ARGLIST:
 663       return dump_subexp_body_funcall (exp, stream, elt);
 664     }
 665
 666   elt += oplen;
 667   for (i = 0; i < nargs; i += 1)
 668     elt = dump_subexp (exp, stream, elt);
 669
 670   return elt;
 671 }
 672
 673 /* Special expression checking for Fortran.  */
 674
 675 static int
 676 operator_check_f (struct expression *exp, int pos,
 677                   int (*objfile_func) (struct objfile *objfile,
 678                                        void *data),
 679                   void *data)
 680 {
 681   const union exp_element *const elts = exp->elts;
 682
 683   switch (elts[pos].opcode)
 684     {
 685     case UNOP_FORTRAN_KIND:
 686     case UNOP_FORTRAN_FLOOR:
 687     case UNOP_FORTRAN_CEILING:
 688     case BINOP_FORTRAN_CMPLX:
 689     case BINOP_FORTRAN_MODULO:
 690       /* Any references to objfiles are held in the arguments to this
 691          expression, not within the expression itself, so no additional
 692          checking is required here, the outer expression iteration code
 693          will take care of checking each argument.  */
 694       break;
 695
 696     default:
 697       return operator_check_standard (exp, pos, objfile_func, data);
 698     }
 699
 700   return 0;
 701 }
 702
 703 /* Expression processing for Fortran.  */
 704 const struct exp_descriptor f_language::exp_descriptor_tab =
 705 {
 706   print_subexp_f,
 707   operator_length_f,
 708   operator_check_f,
 709   op_name_f,
 710   dump_subexp_body_f,
 711   evaluate_subexp_f
 712 };
 713
 714 /* See language.h.  */
 715
 716 void
 717 f_language::language_arch_info (struct gdbarch *gdbarch,
 718                                 struct language_arch_info *lai) const
 719 {
 720   const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
 721
 722   lai->string_char_type = builtin->builtin_character;
 723   lai->primitive_type_vector
 724     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
 725                               struct type *);
 726
 727   lai->primitive_type_vector [f_primitive_type_character]
 728     = builtin->builtin_character;
 729   lai->primitive_type_vector [f_primitive_type_logical]
 730     = builtin->builtin_logical;
 731   lai->primitive_type_vector [f_primitive_type_logical_s1]
 732     = builtin->builtin_logical_s1;
 733   lai->primitive_type_vector [f_primitive_type_logical_s2]
 734     = builtin->builtin_logical_s2;
 735   lai->primitive_type_vector [f_primitive_type_logical_s8]
 736     = builtin->builtin_logical_s8;
 737   lai->primitive_type_vector [f_primitive_type_real]
 738     = builtin->builtin_real;
 739   lai->primitive_type_vector [f_primitive_type_real_s8]
 740     = builtin->builtin_real_s8;
 741   lai->primitive_type_vector [f_primitive_type_real_s16]
 742     = builtin->builtin_real_s16;
 743   lai->primitive_type_vector [f_primitive_type_complex_s8]
 744     = builtin->builtin_complex_s8;
 745   lai->primitive_type_vector [f_primitive_type_complex_s16]
 746     = builtin->builtin_complex_s16;
 747   lai->primitive_type_vector [f_primitive_type_void]
 748     = builtin->builtin_void;
 749
 750   lai->bool_type_symbol = "logical";
 751   lai->bool_type_default = builtin->builtin_logical_s2;
 752 }
 753
 754 /* See language.h.  */
 755
 756 unsigned int
 757 f_language::search_name_hash (const char *name) const
 758 {
 759   return cp_search_name_hash (name);
 760 }
 761
 762 /* See language.h.  */
 763
 764 struct block_symbol
 765 f_language::lookup_symbol_nonlocal (const char *name,
 766                                     const struct block *block,
 767                                     const domain_enum domain) const
 768 {
 769   return cp_lookup_symbol_nonlocal (this, name, block, domain);
 770 }
 771
 772 /* See language.h.  */
 773
 774 symbol_name_matcher_ftype *
 775 f_language::get_symbol_name_matcher_inner
 776         (const lookup_name_info &lookup_name) const
 777 {
 778   return cp_get_symbol_name_matcher (lookup_name);
 779 }
 780
 781 /* Single instance of the Fortran language class.  */
 782
 783 static f_language f_language_defn;
 784
 785 static void *
 786 build_fortran_types (struct gdbarch *gdbarch)
 787 {
 788   struct builtin_f_type *builtin_f_type
 789     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 790
 791   builtin_f_type->builtin_void
 792     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
 793
 794   builtin_f_type->builtin_character
 795     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 796
 797   builtin_f_type->builtin_logical_s1
 798     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 799
 800   builtin_f_type->builtin_integer_s2
 801     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 802                          "integer*2");
 803
 804   builtin_f_type->builtin_integer_s8
 805     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 806                          "integer*8");
 807
 808   builtin_f_type->builtin_logical_s2
 809     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 810                          "logical*2");
 811
 812   builtin_f_type->builtin_logical_s8
 813     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 814                          "logical*8");
 815
 816   builtin_f_type->builtin_integer
 817     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 818                          "integer");
 819
 820   builtin_f_type->builtin_logical
 821     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 822                          "logical*4");
 823
 824   builtin_f_type->builtin_real
 825     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 826                        "real", gdbarch_float_format (gdbarch));
 827   builtin_f_type->builtin_real_s8
 828     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 829                        "real*8", gdbarch_double_format (gdbarch));
 830   auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
 831   if (fmt != nullptr)
 832     builtin_f_type->builtin_real_s16
 833       = arch_float_type (gdbarch, 128, "real*16", fmt);
 834   else if (gdbarch_long_double_bit (gdbarch) == 128)
 835     builtin_f_type->builtin_real_s16
 836       = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 837                          "real*16", gdbarch_long_double_format (gdbarch));
 838   else
 839     builtin_f_type->builtin_real_s16
 840       = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
 841
 842   builtin_f_type->builtin_complex_s8
 843     = init_complex_type ("complex*8", builtin_f_type->builtin_real);
 844   builtin_f_type->builtin_complex_s16
 845     = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
 846
 847   if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
 848     builtin_f_type->builtin_complex_s32
 849       = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
 850   else
 851     builtin_f_type->builtin_complex_s32
 852       = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
 853
 854   return builtin_f_type;
 855 }
 856
 857 static struct gdbarch_data *f_type_data;
 858
 859 const struct builtin_f_type *
 860 builtin_f_type (struct gdbarch *gdbarch)
 861 {
 862   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 863 }
 864
 865 void _initialize_f_language ();
 866 void
 867 _initialize_f_language ()
 868 {
 869   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 870 }
 871
 872 /* See f-lang.h.  */
 873
 874 struct value *
 875 fortran_argument_convert (struct value *value, bool is_artificial)
 876 {
 877   if (!is_artificial)
 878     {
 879       /* If the value is not in the inferior e.g. registers values,
 880          convenience variables and user input.  */
 881       if (VALUE_LVAL (value) != lval_memory)
 882         {
 883           struct type *type = value_type (value);
 884           const int length = TYPE_LENGTH (type);
 885           const CORE_ADDR addr
 886             = value_as_long (value_allocate_space_in_inferior (length));
 887           write_memory (addr, value_contents (value), length);
 888           struct value *val
 889             = value_from_contents_and_address (type, value_contents (value),
 890                                                addr);
 891           return value_addr (val);
 892         }
 893       else
 894         return value_addr (value); /* Program variables, e.g. arrays.  */
 895     }
 896     return value;
 897 }
 898
 899 /* See f-lang.h.  */
 900
 901 struct type *
 902 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 903 {
 904   if (value_type (arg)->code () == TYPE_CODE_PTR)
 905     return value_type (arg);
 906   return type;
 907 }