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       (*pos)++;
 618       print_subexp_funcall (exp, pos, stream);
 619       return;
 620     }
 621 }
 622
 623 /* Special expression names for Fortran.  */
 624
 625 static const char *
 626 op_name_f (enum exp_opcode opcode)
 627 {
 628   switch (opcode)
 629     {
 630     default:
 631       return op_name_standard (opcode);
 632
 633 #define OP(name)        \
 634     case name:          \
 635       return #name ;
 636 #include "fortran-operator.def"
 637 #undef OP
 638     }
 639 }
 640
 641 /* Special expression dumping for Fortran.  */
 642
 643 static int
 644 dump_subexp_body_f (struct expression *exp,
 645                     struct ui_file *stream, int elt)
 646 {
 647   int opcode = exp->elts[elt].opcode;
 648   int oplen, nargs, i;
 649
 650   switch (opcode)
 651     {
 652     default:
 653       return dump_subexp_body_standard (exp, stream, elt);
 654
 655     case UNOP_FORTRAN_KIND:
 656     case UNOP_FORTRAN_FLOOR:
 657     case UNOP_FORTRAN_CEILING:
 658     case BINOP_FORTRAN_CMPLX:
 659     case BINOP_FORTRAN_MODULO:
 660       operator_length_f (exp, (elt + 1), &oplen, &nargs);
 661       break;
 662
 663     case OP_F77_UNDETERMINED_ARGLIST:
 664       return dump_subexp_body_funcall (exp, stream, elt + 1);
 665     }
 666
 667   elt += oplen;
 668   for (i = 0; i < nargs; i += 1)
 669     elt = dump_subexp (exp, stream, elt);
 670
 671   return elt;
 672 }
 673
 674 /* Special expression checking for Fortran.  */
 675
 676 static int
 677 operator_check_f (struct expression *exp, int pos,
 678                   int (*objfile_func) (struct objfile *objfile,
 679                                        void *data),
 680                   void *data)
 681 {
 682   const union exp_element *const elts = exp->elts;
 683
 684   switch (elts[pos].opcode)
 685     {
 686     case UNOP_FORTRAN_KIND:
 687     case UNOP_FORTRAN_FLOOR:
 688     case UNOP_FORTRAN_CEILING:
 689     case BINOP_FORTRAN_CMPLX:
 690     case BINOP_FORTRAN_MODULO:
 691       /* Any references to objfiles are held in the arguments to this
 692          expression, not within the expression itself, so no additional
 693          checking is required here, the outer expression iteration code
 694          will take care of checking each argument.  */
 695       break;
 696
 697     default:
 698       return operator_check_standard (exp, pos, objfile_func, data);
 699     }
 700
 701   return 0;
 702 }
 703
 704 /* Expression processing for Fortran.  */
 705 const struct exp_descriptor f_language::exp_descriptor_tab =
 706 {
 707   print_subexp_f,
 708   operator_length_f,
 709   operator_check_f,
 710   op_name_f,
 711   dump_subexp_body_f,
 712   evaluate_subexp_f
 713 };
 714
 715 /* See language.h.  */
 716
 717 void
 718 f_language::language_arch_info (struct gdbarch *gdbarch,
 719                                 struct language_arch_info *lai) const
 720 {
 721   const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
 722
 723   lai->string_char_type = builtin->builtin_character;
 724   lai->primitive_type_vector
 725     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
 726                               struct type *);
 727
 728   lai->primitive_type_vector [f_primitive_type_character]
 729     = builtin->builtin_character;
 730   lai->primitive_type_vector [f_primitive_type_logical]
 731     = builtin->builtin_logical;
 732   lai->primitive_type_vector [f_primitive_type_logical_s1]
 733     = builtin->builtin_logical_s1;
 734   lai->primitive_type_vector [f_primitive_type_logical_s2]
 735     = builtin->builtin_logical_s2;
 736   lai->primitive_type_vector [f_primitive_type_logical_s8]
 737     = builtin->builtin_logical_s8;
 738   lai->primitive_type_vector [f_primitive_type_real]
 739     = builtin->builtin_real;
 740   lai->primitive_type_vector [f_primitive_type_real_s8]
 741     = builtin->builtin_real_s8;
 742   lai->primitive_type_vector [f_primitive_type_real_s16]
 743     = builtin->builtin_real_s16;
 744   lai->primitive_type_vector [f_primitive_type_complex_s8]
 745     = builtin->builtin_complex_s8;
 746   lai->primitive_type_vector [f_primitive_type_complex_s16]
 747     = builtin->builtin_complex_s16;
 748   lai->primitive_type_vector [f_primitive_type_void]
 749     = builtin->builtin_void;
 750
 751   lai->bool_type_symbol = "logical";
 752   lai->bool_type_default = builtin->builtin_logical_s2;
 753 }
 754
 755 /* See language.h.  */
 756
 757 unsigned int
 758 f_language::search_name_hash (const char *name) const
 759 {
 760   return cp_search_name_hash (name);
 761 }
 762
 763 /* See language.h.  */
 764
 765 struct block_symbol
 766 f_language::lookup_symbol_nonlocal (const char *name,
 767                                     const struct block *block,
 768                                     const domain_enum domain) const
 769 {
 770   return cp_lookup_symbol_nonlocal (this, name, block, domain);
 771 }
 772
 773 /* See language.h.  */
 774
 775 symbol_name_matcher_ftype *
 776 f_language::get_symbol_name_matcher_inner
 777         (const lookup_name_info &lookup_name) const
 778 {
 779   return cp_get_symbol_name_matcher (lookup_name);
 780 }
 781
 782 /* Single instance of the Fortran language class.  */
 783
 784 static f_language f_language_defn;
 785
 786 static void *
 787 build_fortran_types (struct gdbarch *gdbarch)
 788 {
 789   struct builtin_f_type *builtin_f_type
 790     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 791
 792   builtin_f_type->builtin_void
 793     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
 794
 795   builtin_f_type->builtin_character
 796     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 797
 798   builtin_f_type->builtin_logical_s1
 799     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 800
 801   builtin_f_type->builtin_integer_s2
 802     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 803                          "integer*2");
 804
 805   builtin_f_type->builtin_integer_s8
 806     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 807                          "integer*8");
 808
 809   builtin_f_type->builtin_logical_s2
 810     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 811                          "logical*2");
 812
 813   builtin_f_type->builtin_logical_s8
 814     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 815                          "logical*8");
 816
 817   builtin_f_type->builtin_integer
 818     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 819                          "integer");
 820
 821   builtin_f_type->builtin_logical
 822     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 823                          "logical*4");
 824
 825   builtin_f_type->builtin_real
 826     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 827                        "real", gdbarch_float_format (gdbarch));
 828   builtin_f_type->builtin_real_s8
 829     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 830                        "real*8", gdbarch_double_format (gdbarch));
 831   auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
 832   if (fmt != nullptr)
 833     builtin_f_type->builtin_real_s16
 834       = arch_float_type (gdbarch, 128, "real*16", fmt);
 835   else if (gdbarch_long_double_bit (gdbarch) == 128)
 836     builtin_f_type->builtin_real_s16
 837       = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 838                          "real*16", gdbarch_long_double_format (gdbarch));
 839   else
 840     builtin_f_type->builtin_real_s16
 841       = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
 842
 843   builtin_f_type->builtin_complex_s8
 844     = init_complex_type ("complex*8", builtin_f_type->builtin_real);
 845   builtin_f_type->builtin_complex_s16
 846     = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
 847
 848   if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
 849     builtin_f_type->builtin_complex_s32
 850       = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
 851   else
 852     builtin_f_type->builtin_complex_s32
 853       = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
 854
 855   return builtin_f_type;
 856 }
 857
 858 static struct gdbarch_data *f_type_data;
 859
 860 const struct builtin_f_type *
 861 builtin_f_type (struct gdbarch *gdbarch)
 862 {
 863   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 864 }
 865
 866 void _initialize_f_language ();
 867 void
 868 _initialize_f_language ()
 869 {
 870   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 871 }
 872
 873 /* See f-lang.h.  */
 874
 875 struct value *
 876 fortran_argument_convert (struct value *value, bool is_artificial)
 877 {
 878   if (!is_artificial)
 879     {
 880       /* If the value is not in the inferior e.g. registers values,
 881          convenience variables and user input.  */
 882       if (VALUE_LVAL (value) != lval_memory)
 883         {
 884           struct type *type = value_type (value);
 885           const int length = TYPE_LENGTH (type);
 886           const CORE_ADDR addr
 887             = value_as_long (value_allocate_space_in_inferior (length));
 888           write_memory (addr, value_contents (value), length);
 889           struct value *val
 890             = value_from_contents_and_address (type, value_contents (value),
 891                                                addr);
 892           return value_addr (val);
 893         }
 894       else
 895         return value_addr (value); /* Program variables, e.g. arrays.  */
 896     }
 897     return value;
 898 }
 899
 900 /* See f-lang.h.  */
 901
 902 struct type *
 903 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
 904 {
 905   if (value_type (arg)->code () == TYPE_CODE_PTR)
 906     return value_type (arg);
 907   return type;
 908 }