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 static const char *
  48 f_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 static const struct op_print f_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;
 128   struct type *range = check_typedef (value_type (array)->index_type ());
 129   enum range_type range_type
 130     = (enum range_type) longest_to_int (exp->elts[pc].longconst);
 131
 132   *pos += 3;
 133
 134   if (range_type == LOW_BOUND_DEFAULT || range_type == BOTH_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_type == HIGH_BOUND_DEFAULT || range_type == BOTH_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   return value_slice (array, low_bound, high_bound - low_bound + 1);
 145 }
 146
 147 /* Helper for skipping all the arguments in an undetermined argument list.
 148    This function was designed for use in the OP_F77_UNDETERMINED_ARGLIST
 149    case of evaluate_subexp_standard as multiple, but not all, code paths
 150    require a generic skip.  */
 151
 152 static void
 153 skip_undetermined_arglist (int nargs, struct expression *exp, int *pos,
 154                            enum noside noside)
 155 {
 156   for (int i = 0; i < nargs; ++i)
 157     evaluate_subexp (nullptr, exp, pos, noside);
 158 }
 159
 160 /* Return the number of dimensions for a Fortran array or string.  */
 161
 162 int
 163 calc_f77_array_dims (struct type *array_type)
 164 {
 165   int ndimen = 1;
 166   struct type *tmp_type;
 167
 168   if ((array_type->code () == TYPE_CODE_STRING))
 169     return 1;
 170
 171   if ((array_type->code () != TYPE_CODE_ARRAY))
 172     error (_("Can't get dimensions for a non-array type"));
 173
 174   tmp_type = array_type;
 175
 176   while ((tmp_type = TYPE_TARGET_TYPE (tmp_type)))
 177     {
 178       if (tmp_type->code () == TYPE_CODE_ARRAY)
 179         ++ndimen;
 180     }
 181   return ndimen;
 182 }
 183
 184 /* Called from evaluate_subexp_standard to perform array indexing, and
 185    sub-range extraction, for Fortran.  As well as arrays this function
 186    also handles strings as they can be treated like arrays of characters.
 187    ARRAY is the array or string being accessed.  EXP, POS, and NOSIDE are
 188    as for evaluate_subexp_standard, and NARGS is the number of arguments
 189    in this access (e.g. 'array (1,2,3)' would be NARGS 3).  */
 190
 191 static struct value *
 192 fortran_value_subarray (struct value *array, struct expression *exp,
 193                         int *pos, int nargs, enum noside noside)
 194 {
 195   if (exp->elts[*pos].opcode == OP_RANGE)
 196     return value_f90_subarray (array, exp, pos, noside);
 197
 198   if (noside == EVAL_SKIP)
 199     {
 200       skip_undetermined_arglist (nargs, exp, pos, noside);
 201       /* Return the dummy value with the correct type.  */
 202       return array;
 203     }
 204
 205   LONGEST subscript_array[MAX_FORTRAN_DIMS];
 206   int ndimensions = 1;
 207   struct type *type = check_typedef (value_type (array));
 208
 209   if (nargs > MAX_FORTRAN_DIMS)
 210     error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS);
 211
 212   ndimensions = calc_f77_array_dims (type);
 213
 214   if (nargs != ndimensions)
 215     error (_("Wrong number of subscripts"));
 216
 217   gdb_assert (nargs > 0);
 218
 219   /* Now that we know we have a legal array subscript expression let us
 220      actually find out where this element exists in the array.  */
 221
 222   /* Take array indices left to right.  */
 223   for (int i = 0; i < nargs; i++)
 224     {
 225       /* Evaluate each subscript; it must be a legal integer in F77.  */
 226       value *arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 227
 228       /* Fill in the subscript array.  */
 229       subscript_array[i] = value_as_long (arg2);
 230     }
 231
 232   /* Internal type of array is arranged right to left.  */
 233   for (int i = nargs; i > 0; i--)
 234     {
 235       struct type *array_type = check_typedef (value_type (array));
 236       LONGEST index = subscript_array[i - 1];
 237
 238       array = value_subscripted_rvalue (array, index,
 239                                         f77_get_lowerbound (array_type));
 240     }
 241
 242   return array;
 243 }
 244
 245 /* Special expression evaluation cases for Fortran.  */
 246
 247 static struct value *
 248 evaluate_subexp_f (struct type *expect_type, struct expression *exp,
 249                    int *pos, enum noside noside)
 250 {
 251   struct value *arg1 = NULL, *arg2 = NULL;
 252   enum exp_opcode op;
 253   int pc;
 254   struct type *type;
 255
 256   pc = *pos;
 257   *pos += 1;
 258   op = exp->elts[pc].opcode;
 259
 260   switch (op)
 261     {
 262     default:
 263       *pos -= 1;
 264       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 265
 266     case UNOP_ABS:
 267       arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 268       if (noside == EVAL_SKIP)
 269         return eval_skip_value (exp);
 270       type = value_type (arg1);
 271       switch (type->code ())
 272         {
 273         case TYPE_CODE_FLT:
 274           {
 275             double d
 276               = fabs (target_float_to_host_double (value_contents (arg1),
 277                                                    value_type (arg1)));
 278             return value_from_host_double (type, d);
 279           }
 280         case TYPE_CODE_INT:
 281           {
 282             LONGEST l = value_as_long (arg1);
 283             l = llabs (l);
 284             return value_from_longest (type, l);
 285           }
 286         }
 287       error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
 288
 289     case BINOP_MOD:
 290       arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 291       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 292       if (noside == EVAL_SKIP)
 293         return eval_skip_value (exp);
 294       type = value_type (arg1);
 295       if (type->code () != value_type (arg2)->code ())
 296         error (_("non-matching types for parameters to MOD ()"));
 297       switch (type->code ())
 298         {
 299         case TYPE_CODE_FLT:
 300           {
 301             double d1
 302               = target_float_to_host_double (value_contents (arg1),
 303                                              value_type (arg1));
 304             double d2
 305               = target_float_to_host_double (value_contents (arg2),
 306                                              value_type (arg2));
 307             double d3 = fmod (d1, d2);
 308             return value_from_host_double (type, d3);
 309           }
 310         case TYPE_CODE_INT:
 311           {
 312             LONGEST v1 = value_as_long (arg1);
 313             LONGEST v2 = value_as_long (arg2);
 314             if (v2 == 0)
 315               error (_("calling MOD (N, 0) is undefined"));
 316             LONGEST v3 = v1 - (v1 / v2) * v2;
 317             return value_from_longest (value_type (arg1), v3);
 318           }
 319         }
 320       error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
 321
 322     case UNOP_FORTRAN_CEILING:
 323       {
 324         arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 325         if (noside == EVAL_SKIP)
 326           return eval_skip_value (exp);
 327         type = value_type (arg1);
 328         if (type->code () != TYPE_CODE_FLT)
 329           error (_("argument to CEILING must be of type float"));
 330         double val
 331           = target_float_to_host_double (value_contents (arg1),
 332                                          value_type (arg1));
 333         val = ceil (val);
 334         return value_from_host_double (type, val);
 335       }
 336
 337     case UNOP_FORTRAN_FLOOR:
 338       {
 339         arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 340         if (noside == EVAL_SKIP)
 341           return eval_skip_value (exp);
 342         type = value_type (arg1);
 343         if (type->code () != TYPE_CODE_FLT)
 344           error (_("argument to FLOOR must be of type float"));
 345         double val
 346           = target_float_to_host_double (value_contents (arg1),
 347                                          value_type (arg1));
 348         val = floor (val);
 349         return value_from_host_double (type, val);
 350       }
 351
 352     case BINOP_FORTRAN_MODULO:
 353       {
 354         arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 355         arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 356         if (noside == EVAL_SKIP)
 357           return eval_skip_value (exp);
 358         type = value_type (arg1);
 359         if (type->code () != value_type (arg2)->code ())
 360           error (_("non-matching types for parameters to MODULO ()"));
 361         /* MODULO(A, P) = A - FLOOR (A / P) * P */
 362         switch (type->code ())
 363           {
 364           case TYPE_CODE_INT:
 365             {
 366               LONGEST a = value_as_long (arg1);
 367               LONGEST p = value_as_long (arg2);
 368               LONGEST result = a - (a / p) * p;
 369               if (result != 0 && (a < 0) != (p < 0))
 370                 result += p;
 371               return value_from_longest (value_type (arg1), result);
 372             }
 373           case TYPE_CODE_FLT:
 374             {
 375               double a
 376                 = target_float_to_host_double (value_contents (arg1),
 377                                                value_type (arg1));
 378               double p
 379                 = target_float_to_host_double (value_contents (arg2),
 380                                                value_type (arg2));
 381               double result = fmod (a, p);
 382               if (result != 0 && (a < 0.0) != (p < 0.0))
 383                 result += p;
 384               return value_from_host_double (type, result);
 385             }
 386           }
 387         error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
 388       }
 389
 390     case BINOP_FORTRAN_CMPLX:
 391       arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 392       arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
 393       if (noside == EVAL_SKIP)
 394         return eval_skip_value (exp);
 395       type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
 396       return value_literal_complex (arg1, arg2, type);
 397
 398     case UNOP_FORTRAN_KIND:
 399       arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
 400       type = value_type (arg1);
 401
 402       switch (type->code ())
 403         {
 404           case TYPE_CODE_STRUCT:
 405           case TYPE_CODE_UNION:
 406           case TYPE_CODE_MODULE:
 407           case TYPE_CODE_FUNC:
 408             error (_("argument to kind must be an intrinsic type"));
 409         }
 410
 411       if (!TYPE_TARGET_TYPE (type))
 412         return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 413                                    TYPE_LENGTH (type));
 414       return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
 415                                  TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
 416
 417
 418     case OP_F77_UNDETERMINED_ARGLIST:
 419       /* Remember that in F77, functions, substring ops and array subscript
 420          operations cannot be disambiguated at parse time.  We have made
 421          all array subscript operations, substring operations as well as
 422          function calls come here and we now have to discover what the heck
 423          this thing actually was.  If it is a function, we process just as
 424          if we got an OP_FUNCALL.  */
 425       int nargs = longest_to_int (exp->elts[pc + 1].longconst);
 426       (*pos) += 2;
 427
 428       /* First determine the type code we are dealing with.  */
 429       arg1 = evaluate_subexp (nullptr, exp, pos, noside);
 430       type = check_typedef (value_type (arg1));
 431       enum type_code code = type->code ();
 432
 433       if (code == TYPE_CODE_PTR)
 434         {
 435           /* Fortran always passes variable to subroutines as pointer.
 436              So we need to look into its target type to see if it is
 437              array, string or function.  If it is, we need to switch
 438              to the target value the original one points to.  */
 439           struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
 440
 441           if (target_type->code () == TYPE_CODE_ARRAY
 442               || target_type->code () == TYPE_CODE_STRING
 443               || target_type->code () == TYPE_CODE_FUNC)
 444             {
 445               arg1 = value_ind (arg1);
 446               type = check_typedef (value_type (arg1));
 447               code = type->code ();
 448             }
 449         }
 450
 451       switch (code)
 452         {
 453         case TYPE_CODE_ARRAY:
 454         case TYPE_CODE_STRING:
 455           return fortran_value_subarray (arg1, exp, pos, nargs, noside);
 456
 457         case TYPE_CODE_PTR:
 458         case TYPE_CODE_FUNC:
 459         case TYPE_CODE_INTERNAL_FUNCTION:
 460           {
 461             /* It's a function call.  Allocate arg vector, including
 462             space for the function to be called in argvec[0] and a
 463             termination NULL.  */
 464             struct value **argvec = (struct value **)
 465               alloca (sizeof (struct value *) * (nargs + 2));
 466             argvec[0] = arg1;
 467             int tem = 1;
 468             for (; tem <= nargs; tem++)
 469               {
 470                 argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
 471                 /* Arguments in Fortran are passed by address.  Coerce the
 472                    arguments here rather than in value_arg_coerce as
 473                    otherwise the call to malloc to place the non-lvalue
 474                    parameters in target memory is hit by this Fortran
 475                    specific logic.  This results in malloc being called
 476                    with a pointer to an integer followed by an attempt to
 477                    malloc the arguments to malloc in target memory.
 478                    Infinite recursion ensues.  */
 479                 if (code == TYPE_CODE_PTR || code == TYPE_CODE_FUNC)
 480                   {
 481                     bool is_artificial
 482                       = TYPE_FIELD_ARTIFICIAL (value_type (arg1), tem - 1);
 483                     argvec[tem] = fortran_argument_convert (argvec[tem],
 484                                                             is_artificial);
 485                   }
 486               }
 487             argvec[tem] = 0;    /* signal end of arglist */
 488             if (noside == EVAL_SKIP)
 489               return eval_skip_value (exp);
 490             return evaluate_subexp_do_call (exp, noside, nargs, argvec, NULL,
 491                                             expect_type);
 492           }
 493
 494         default:
 495           error (_("Cannot perform substring on this type"));
 496         }
 497     }
 498
 499   /* Should be unreachable.  */
 500   return nullptr;
 501 }
 502
 503 /* Special expression lengths for Fortran.  */
 504
 505 static void
 506 operator_length_f (const struct expression *exp, int pc, int *oplenp,
 507                    int *argsp)
 508 {
 509   int oplen = 1;
 510   int args = 0;
 511
 512   switch (exp->elts[pc - 1].opcode)
 513     {
 514     default:
 515       operator_length_standard (exp, pc, oplenp, argsp);
 516       return;
 517
 518     case UNOP_FORTRAN_KIND:
 519     case UNOP_FORTRAN_FLOOR:
 520     case UNOP_FORTRAN_CEILING:
 521       oplen = 1;
 522       args = 1;
 523       break;
 524
 525     case BINOP_FORTRAN_CMPLX:
 526     case BINOP_FORTRAN_MODULO:
 527       oplen = 1;
 528       args = 2;
 529       break;
 530
 531     case OP_F77_UNDETERMINED_ARGLIST:
 532       oplen = 3;
 533       args = 1 + longest_to_int (exp->elts[pc - 2].longconst);
 534       break;
 535     }
 536
 537   *oplenp = oplen;
 538   *argsp = args;
 539 }
 540
 541 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 542    the extra argument NAME which is the text that should be printed as the
 543    name of this operation.  */
 544
 545 static void
 546 print_unop_subexp_f (struct expression *exp, int *pos,
 547                      struct ui_file *stream, enum precedence prec,
 548                      const char *name)
 549 {
 550   (*pos)++;
 551   fprintf_filtered (stream, "%s(", name);
 552   print_subexp (exp, pos, stream, PREC_SUFFIX);
 553   fputs_filtered (")", stream);
 554 }
 555
 556 /* Helper for PRINT_SUBEXP_F.  Arguments are as for PRINT_SUBEXP_F, except
 557    the extra argument NAME which is the text that should be printed as the
 558    name of this operation.  */
 559
 560 static void
 561 print_binop_subexp_f (struct expression *exp, int *pos,
 562                       struct ui_file *stream, enum precedence prec,
 563                       const char *name)
 564 {
 565   (*pos)++;
 566   fprintf_filtered (stream, "%s(", name);
 567   print_subexp (exp, pos, stream, PREC_SUFFIX);
 568   fputs_filtered (",", stream);
 569   print_subexp (exp, pos, stream, PREC_SUFFIX);
 570   fputs_filtered (")", stream);
 571 }
 572
 573 /* Special expression printing for Fortran.  */
 574
 575 static void
 576 print_subexp_f (struct expression *exp, int *pos,
 577                 struct ui_file *stream, enum precedence prec)
 578 {
 579   int pc = *pos;
 580   enum exp_opcode op = exp->elts[pc].opcode;
 581
 582   switch (op)
 583     {
 584     default:
 585       print_subexp_standard (exp, pos, stream, prec);
 586       return;
 587
 588     case UNOP_FORTRAN_KIND:
 589       print_unop_subexp_f (exp, pos, stream, prec, "KIND");
 590       return;
 591
 592     case UNOP_FORTRAN_FLOOR:
 593       print_unop_subexp_f (exp, pos, stream, prec, "FLOOR");
 594       return;
 595
 596     case UNOP_FORTRAN_CEILING:
 597       print_unop_subexp_f (exp, pos, stream, prec, "CEILING");
 598       return;
 599
 600     case BINOP_FORTRAN_CMPLX:
 601       print_binop_subexp_f (exp, pos, stream, prec, "CMPLX");
 602       return;
 603
 604     case BINOP_FORTRAN_MODULO:
 605       print_binop_subexp_f (exp, pos, stream, prec, "MODULO");
 606       return;
 607
 608     case OP_F77_UNDETERMINED_ARGLIST:
 609       print_subexp_funcall (exp, pos, stream);
 610       return;
 611     }
 612 }
 613
 614 /* Special expression names for Fortran.  */
 615
 616 static const char *
 617 op_name_f (enum exp_opcode opcode)
 618 {
 619   switch (opcode)
 620     {
 621     default:
 622       return op_name_standard (opcode);
 623
 624 #define OP(name)        \
 625     case name:          \
 626       return #name ;
 627 #include "fortran-operator.def"
 628 #undef OP
 629     }
 630 }
 631
 632 /* Special expression dumping for Fortran.  */
 633
 634 static int
 635 dump_subexp_body_f (struct expression *exp,
 636                     struct ui_file *stream, int elt)
 637 {
 638   int opcode = exp->elts[elt].opcode;
 639   int oplen, nargs, i;
 640
 641   switch (opcode)
 642     {
 643     default:
 644       return dump_subexp_body_standard (exp, stream, elt);
 645
 646     case UNOP_FORTRAN_KIND:
 647     case UNOP_FORTRAN_FLOOR:
 648     case UNOP_FORTRAN_CEILING:
 649     case BINOP_FORTRAN_CMPLX:
 650     case BINOP_FORTRAN_MODULO:
 651       operator_length_f (exp, (elt + 1), &oplen, &nargs);
 652       break;
 653
 654     case OP_F77_UNDETERMINED_ARGLIST:
 655       return dump_subexp_body_funcall (exp, stream, elt);
 656     }
 657
 658   elt += oplen;
 659   for (i = 0; i < nargs; i += 1)
 660     elt = dump_subexp (exp, stream, elt);
 661
 662   return elt;
 663 }
 664
 665 /* Special expression checking for Fortran.  */
 666
 667 static int
 668 operator_check_f (struct expression *exp, int pos,
 669                   int (*objfile_func) (struct objfile *objfile,
 670                                        void *data),
 671                   void *data)
 672 {
 673   const union exp_element *const elts = exp->elts;
 674
 675   switch (elts[pos].opcode)
 676     {
 677     case UNOP_FORTRAN_KIND:
 678     case UNOP_FORTRAN_FLOOR:
 679     case UNOP_FORTRAN_CEILING:
 680     case BINOP_FORTRAN_CMPLX:
 681     case BINOP_FORTRAN_MODULO:
 682       /* Any references to objfiles are held in the arguments to this
 683          expression, not within the expression itself, so no additional
 684          checking is required here, the outer expression iteration code
 685          will take care of checking each argument.  */
 686       break;
 687
 688     default:
 689       return operator_check_standard (exp, pos, objfile_func, data);
 690     }
 691
 692   return 0;
 693 }
 694
 695 /* Expression processing for Fortran.  */
 696 static const struct exp_descriptor exp_descriptor_f =
 697 {
 698   print_subexp_f,
 699   operator_length_f,
 700   operator_check_f,
 701   op_name_f,
 702   dump_subexp_body_f,
 703   evaluate_subexp_f
 704 };
 705
 706 /* Class representing the Fortran language.  */
 707
 708 class f_language : public language_defn
 709 {
 710 public:
 711   f_language ()
 712     : language_defn (language_fortran)
 713   { /* Nothing.  */ }
 714
 715   /* See language.h.  */
 716
 717   const char *name () const override
 718   { return "fortran"; }
 719
 720   /* See language.h.  */
 721
 722   const char *natural_name () const override
 723   { return "Fortran"; }
 724
 725   /* See language.h.  */
 726
 727   const std::vector<const char *> &filename_extensions () const override
 728   {
 729     static const std::vector<const char *> extensions = {
 730       ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 731       ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08"
 732     };
 733     return extensions;
 734   }
 735
 736   /* See language.h.  */
 737   void language_arch_info (struct gdbarch *gdbarch,
 738                            struct language_arch_info *lai) const override
 739   {
 740     const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
 741
 742     lai->string_char_type = builtin->builtin_character;
 743     lai->primitive_type_vector
 744       = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
 745                                 struct type *);
 746
 747     lai->primitive_type_vector [f_primitive_type_character]
 748       = builtin->builtin_character;
 749     lai->primitive_type_vector [f_primitive_type_logical]
 750       = builtin->builtin_logical;
 751     lai->primitive_type_vector [f_primitive_type_logical_s1]
 752       = builtin->builtin_logical_s1;
 753     lai->primitive_type_vector [f_primitive_type_logical_s2]
 754       = builtin->builtin_logical_s2;
 755     lai->primitive_type_vector [f_primitive_type_logical_s8]
 756       = builtin->builtin_logical_s8;
 757     lai->primitive_type_vector [f_primitive_type_real]
 758       = builtin->builtin_real;
 759     lai->primitive_type_vector [f_primitive_type_real_s8]
 760       = builtin->builtin_real_s8;
 761     lai->primitive_type_vector [f_primitive_type_real_s16]
 762       = builtin->builtin_real_s16;
 763     lai->primitive_type_vector [f_primitive_type_complex_s8]
 764       = builtin->builtin_complex_s8;
 765     lai->primitive_type_vector [f_primitive_type_complex_s16]
 766       = builtin->builtin_complex_s16;
 767     lai->primitive_type_vector [f_primitive_type_void]
 768       = builtin->builtin_void;
 769
 770     lai->bool_type_symbol = "logical";
 771     lai->bool_type_default = builtin->builtin_logical_s2;
 772   }
 773
 774   /* See language.h.  */
 775   unsigned int search_name_hash (const char *name) const override
 776   {
 777     return cp_search_name_hash (name);
 778   }
 779
 780   /* See language.h.  */
 781
 782   char *demangle (const char *mangled, int options) const override
 783   {
 784       /* We could support demangling here to provide module namespaces
 785          also for inferiors with only minimal symbol table (ELF symbols).
 786          Just the mangling standard is not standardized across compilers
 787          and there is no DW_AT_producer available for inferiors with only
 788          the ELF symbols to check the mangling kind.  */
 789     return nullptr;
 790   }
 791
 792   /* See language.h.  */
 793
 794   void print_type (struct type *type, const char *varstring,
 795                    struct ui_file *stream, int show, int level,
 796                    const struct type_print_options *flags) const override
 797   {
 798     f_print_type (type, varstring, stream, show, level, flags);
 799   }
 800
 801   /* See language.h.  This just returns default set of word break
 802      characters but with the modules separator `::' removed.  */
 803
 804   const char *word_break_characters (void) const override
 805   {
 806     static char *retval;
 807
 808     if (!retval)
 809       {
 810         char *s;
 811
 812         retval = xstrdup (language_defn::word_break_characters ());
 813         s = strchr (retval, ':');
 814         if (s)
 815           {
 816             char *last_char = &s[strlen (s) - 1];
 817
 818             *s = *last_char;
 819             *last_char = 0;
 820           }
 821       }
 822     return retval;
 823   }
 824
 825
 826   /* See language.h.  */
 827
 828   void collect_symbol_completion_matches (completion_tracker &tracker,
 829                                           complete_symbol_mode mode,
 830                                           symbol_name_match_type name_match_type,
 831                                           const char *text, const char *word,
 832                                           enum type_code code) const override
 833   {
 834     /* Consider the modules separator :: as a valid symbol name character
 835        class.  */
 836     default_collect_symbol_completion_matches_break_on (tracker, mode,
 837                                                         name_match_type,
 838                                                         text, word, ":",
 839                                                         code);
 840   }
 841
 842   /* See language.h.  */
 843
 844   void value_print_inner
 845         (struct value *val, struct ui_file *stream, int recurse,
 846          const struct value_print_options *options) const override
 847   {
 848     return f_value_print_inner (val, stream, recurse, options);
 849   }
 850
 851   /* See language.h.  */
 852
 853   struct block_symbol lookup_symbol_nonlocal
 854         (const char *name, const struct block *block,
 855          const domain_enum domain) const override
 856   {
 857     return cp_lookup_symbol_nonlocal (this, name, block, domain);
 858   }
 859
 860   /* See language.h.  */
 861
 862   int parser (struct parser_state *ps) const override
 863   {
 864     return f_parse (ps);
 865   }
 866
 867   /* See language.h.  */
 868
 869   void emitchar (int ch, struct type *chtype,
 870                  struct ui_file *stream, int quoter) const override
 871   {
 872     const char *encoding = f_get_encoding (chtype);
 873     generic_emit_char (ch, chtype, stream, quoter, encoding);
 874   }
 875
 876   /* See language.h.  */
 877
 878   void printchar (int ch, struct type *chtype,
 879                   struct ui_file *stream) const override
 880   {
 881     fputs_filtered ("'", stream);
 882     LA_EMIT_CHAR (ch, chtype, stream, '\'');
 883     fputs_filtered ("'", stream);
 884   }
 885
 886   /* See language.h.  */
 887
 888   void printstr (struct ui_file *stream, struct type *elttype,
 889                  const gdb_byte *string, unsigned int length,
 890                  const char *encoding, int force_ellipses,
 891                  const struct value_print_options *options) const override
 892   {
 893     const char *type_encoding = f_get_encoding (elttype);
 894
 895     if (TYPE_LENGTH (elttype) == 4)
 896       fputs_filtered ("4_", stream);
 897
 898     if (!encoding || !*encoding)
 899       encoding = type_encoding;
 900
 901     generic_printstr (stream, elttype, string, length, encoding,
 902                       force_ellipses, '\'', 0, options);
 903   }
 904
 905   /* See language.h.  */
 906
 907   void print_typedef (struct type *type, struct symbol *new_symbol,
 908                       struct ui_file *stream) const override
 909   {
 910     f_print_typedef (type, new_symbol, stream);
 911   }
 912
 913   /* See language.h.  */
 914
 915   bool is_string_type_p (struct type *type) const override
 916   {
 917     type = check_typedef (type);
 918     return (type->code () == TYPE_CODE_STRING
 919             || (type->code () == TYPE_CODE_ARRAY
 920                 && TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_CHAR));
 921   }
 922
 923   /* See language.h.  */
 924
 925   const char *struct_too_deep_ellipsis () const override
 926   { return "(...)"; }
 927
 928   /* See language.h.  */
 929
 930   bool c_style_arrays_p () const override
 931   { return false; }
 932
 933   /* See language.h.  */
 934
 935   bool range_checking_on_by_default () const override
 936   { return true; }
 937
 938   /* See language.h.  */
 939
 940   enum case_sensitivity case_sensitivity () const override
 941   { return case_sensitive_off; }
 942
 943   /* See language.h.  */
 944
 945   enum array_ordering array_ordering () const override
 946   { return array_column_major; }
 947
 948   /* See language.h.  */
 949
 950   const struct exp_descriptor *expression_ops () const override
 951   { return &exp_descriptor_f; }
 952
 953   /* See language.h.  */
 954
 955   const struct op_print *opcode_print_table () const override
 956   { return f_op_print_tab; }
 957
 958 protected:
 959
 960   /* See language.h.  */
 961
 962   symbol_name_matcher_ftype *get_symbol_name_matcher_inner
 963         (const lookup_name_info &lookup_name) const override
 964   {
 965     return cp_get_symbol_name_matcher (lookup_name);
 966   }
 967 };
 968
 969 /* Single instance of the Fortran language class.  */
 970
 971 static f_language f_language_defn;
 972
 973 static void *
 974 build_fortran_types (struct gdbarch *gdbarch)
 975 {
 976   struct builtin_f_type *builtin_f_type
 977     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 978
 979   builtin_f_type->builtin_void
 980     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
 981
 982   builtin_f_type->builtin_character
 983     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
 984
 985   builtin_f_type->builtin_logical_s1
 986     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 987
 988   builtin_f_type->builtin_integer_s2
 989     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 990                          "integer*2");
 991
 992   builtin_f_type->builtin_integer_s8
 993     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
 994                          "integer*8");
 995
 996   builtin_f_type->builtin_logical_s2
 997     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 998                          "logical*2");
 999
1000   builtin_f_type->builtin_logical_s8
1001     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
1002                          "logical*8");
1003
1004   builtin_f_type->builtin_integer
1005     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
1006                          "integer");
1007
1008   builtin_f_type->builtin_logical
1009     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
1010                          "logical*4");
1011
1012   builtin_f_type->builtin_real
1013     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
1014                        "real", gdbarch_float_format (gdbarch));
1015   builtin_f_type->builtin_real_s8
1016     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
1017                        "real*8", gdbarch_double_format (gdbarch));
1018   auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
1019   if (fmt != nullptr)
1020     builtin_f_type->builtin_real_s16
1021       = arch_float_type (gdbarch, 128, "real*16", fmt);
1022   else if (gdbarch_long_double_bit (gdbarch) == 128)
1023     builtin_f_type->builtin_real_s16
1024       = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
1025                          "real*16", gdbarch_long_double_format (gdbarch));
1026   else
1027     builtin_f_type->builtin_real_s16
1028       = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
1029
1030   builtin_f_type->builtin_complex_s8
1031     = init_complex_type ("complex*8", builtin_f_type->builtin_real);
1032   builtin_f_type->builtin_complex_s16
1033     = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
1034
1035   if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
1036     builtin_f_type->builtin_complex_s32
1037       = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
1038   else
1039     builtin_f_type->builtin_complex_s32
1040       = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
1041
1042   return builtin_f_type;
1043 }
1044
1045 static struct gdbarch_data *f_type_data;
1046
1047 const struct builtin_f_type *
1048 builtin_f_type (struct gdbarch *gdbarch)
1049 {
1050   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
1051 }
1052
1053 void _initialize_f_language ();
1054 void
1055 _initialize_f_language ()
1056 {
1057   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
1058 }
1059
1060 /* See f-lang.h.  */
1061
1062 struct value *
1063 fortran_argument_convert (struct value *value, bool is_artificial)
1064 {
1065   if (!is_artificial)
1066     {
1067       /* If the value is not in the inferior e.g. registers values,
1068          convenience variables and user input.  */
1069       if (VALUE_LVAL (value) != lval_memory)
1070         {
1071           struct type *type = value_type (value);
1072           const int length = TYPE_LENGTH (type);
1073           const CORE_ADDR addr
1074             = value_as_long (value_allocate_space_in_inferior (length));
1075           write_memory (addr, value_contents (value), length);
1076           struct value *val
1077             = value_from_contents_and_address (type, value_contents (value),
1078                                                addr);
1079           return value_addr (val);
1080         }
1081       else
1082         return value_addr (value); /* Program variables, e.g. arrays.  */
1083     }
1084     return value;
1085 }
1086
1087 /* See f-lang.h.  */
1088
1089 struct type *
1090 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
1091 {
1092   if (value_type (arg)->code () == TYPE_CODE_PTR)
1093     return value_type (arg);
1094   return type;
1095 }