gdb/f-exp.y

   1
   2 /* YACC parser for Fortran expressions, for GDB.
   3    Copyright (C) 1986-2022 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 /* This was blantantly ripped off the C expression parser, please
  24    be aware of that as you look at its basic structure -FMB */
  25
  26 /* Parse a F77 expression from text in a string,
  27    and return the result as a  struct expression  pointer.
  28    That structure contains arithmetic operations in reverse polish,
  29    with constants represented by operations that are followed by special data.
  30    See expression.h for the details of the format.
  31    What is important here is that it can be built up sequentially
  32    during the process of parsing; the lower levels of the tree always
  33    come first in the result.
  34
  35    Note that malloc's and realloc's in this file are transformed to
  36    xmalloc and xrealloc respectively by the same sed command in the
  37    makefile that remaps any other malloc/realloc inserted by the parser
  38    generator.  Doing this with #defines and trying to control the interaction
  39    with include files (<malloc.h> and <stdlib.h> for example) just became
  40    too messy, particularly when such includes can be inserted at random
  41    times by the parser generator.  */
  42
  43 %{
  44
  45 #include "defs.h"
  46 #include "expression.h"
  47 #include "value.h"
  48 #include "parser-defs.h"
  49 #include "language.h"
  50 #include "f-lang.h"
  51 #include "bfd.h" /* Required by objfiles.h.  */
  52 #include "symfile.h" /* Required by objfiles.h.  */
  53 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
  54 #include "block.h"
  55 #include <ctype.h>
  56 #include <algorithm>
  57 #include "type-stack.h"
  58 #include "f-exp.h"
  59
  60 #define parse_type(ps) builtin_type (ps->gdbarch ())
  61 #define parse_f_type(ps) builtin_f_type (ps->gdbarch ())
  62
  63 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
  64    etc).  */
  65 #define GDB_YY_REMAP_PREFIX f_
  66 #include "yy-remap.h"
  67
  68 /* The state of the parser, used internally when we are parsing the
  69    expression.  */
  70
  71 static struct parser_state *pstate = NULL;
  72
  73 /* Depth of parentheses.  */
  74 static int paren_depth;
  75
  76 /* The current type stack.  */
  77 static struct type_stack *type_stack;
  78
  79 int yyparse (void);
  80
  81 static int yylex (void);
  82
  83 static void yyerror (const char *);
  84
  85 static void growbuf_by_size (int);
  86
  87 static int match_string_literal (void);
  88
  89 static void push_kind_type (LONGEST val, struct type *type);
  90
  91 static struct type *convert_to_kind_type (struct type *basetype, int kind);
  92
  93 static void wrap_unop_intrinsic (exp_opcode opcode);
  94
  95 static void wrap_binop_intrinsic (exp_opcode opcode);
  96
  97 static void wrap_ternop_intrinsic (exp_opcode opcode);
  98
  99 template<typename T>
 100 static void fortran_wrap2_kind (type *base_type);
 101
 102 template<typename T>
 103 static void fortran_wrap3_kind (type *base_type);
 104
 105 using namespace expr;
 106 %}
 107
 108 /* Although the yacc "value" of an expression is not used,
 109    since the result is stored in the structure being created,
 110    other node types do have values.  */
 111
 112 %union
 113   {
 114     LONGEST lval;
 115     struct {
 116       LONGEST val;
 117       struct type *type;
 118     } typed_val;
 119     struct {
 120       gdb_byte val[16];
 121       struct type *type;
 122     } typed_val_float;
 123     struct symbol *sym;
 124     struct type *tval;
 125     struct stoken sval;
 126     struct ttype tsym;
 127     struct symtoken ssym;
 128     int voidval;
 129     enum exp_opcode opcode;
 130     struct internalvar *ivar;
 131
 132     struct type **tvec;
 133     int *ivec;
 134   }
 135
 136 %{
 137 /* YYSTYPE gets defined by %union */
 138 static int parse_number (struct parser_state *, const char *, int,
 139                          int, YYSTYPE *);
 140 %}
 141
 142 %type <voidval> exp  type_exp start variable
 143 %type <tval> type typebase
 144 %type <tvec> nonempty_typelist
 145 /* %type <bval> block */
 146
 147 /* Fancy type parsing.  */
 148 %type <voidval> func_mod direct_abs_decl abs_decl
 149 %type <tval> ptype
 150
 151 %token <typed_val> INT
 152 %token <typed_val_float> FLOAT
 153
 154 /* Both NAME and TYPENAME tokens represent symbols in the input,
 155    and both convey their data as strings.
 156    But a TYPENAME is a string that happens to be defined as a typedef
 157    or builtin type name (such as int or char)
 158    and a NAME is any other symbol.
 159    Contexts where this distinction is not important can use the
 160    nonterminal "name", which matches either NAME or TYPENAME.  */
 161
 162 %token <sval> STRING_LITERAL
 163 %token <lval> BOOLEAN_LITERAL
 164 %token <ssym> NAME
 165 %token <tsym> TYPENAME
 166 %token <voidval> COMPLETE
 167 %type <sval> name
 168 %type <ssym> name_not_typename
 169
 170 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
 171    but which would parse as a valid number in the current input radix.
 172    E.g. "c" when input_radix==16.  Depending on the parse, it will be
 173    turned into a name or into a number.  */
 174
 175 %token <ssym> NAME_OR_INT
 176
 177 %token SIZEOF KIND
 178 %token ERROR
 179
 180 /* Special type cases, put in to allow the parser to distinguish different
 181    legal basetypes.  */
 182 %token INT_S1_KEYWORD INT_S2_KEYWORD INT_KEYWORD INT_S4_KEYWORD INT_S8_KEYWORD
 183 %token LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD LOGICAL_KEYWORD LOGICAL_S4_KEYWORD
 184 %token LOGICAL_S8_KEYWORD
 185 %token REAL_KEYWORD REAL_S4_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
 186 %token COMPLEX_KEYWORD COMPLEX_S4_KEYWORD COMPLEX_S8_KEYWORD
 187 %token COMPLEX_S16_KEYWORD
 188 %token BOOL_AND BOOL_OR BOOL_NOT
 189 %token SINGLE DOUBLE PRECISION
 190 %token <lval> CHARACTER
 191
 192 %token <sval> DOLLAR_VARIABLE
 193
 194 %token <opcode> ASSIGN_MODIFY
 195 %token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
 196 %token <opcode> UNOP_OR_BINOP_INTRINSIC UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
 197
 198 %left ','
 199 %left ABOVE_COMMA
 200 %right '=' ASSIGN_MODIFY
 201 %right '?'
 202 %left BOOL_OR
 203 %right BOOL_NOT
 204 %left BOOL_AND
 205 %left '|'
 206 %left '^'
 207 %left '&'
 208 %left EQUAL NOTEQUAL
 209 %left LESSTHAN GREATERTHAN LEQ GEQ
 210 %left LSH RSH
 211 %left '@'
 212 %left '+' '-'
 213 %left '*' '/'
 214 %right STARSTAR
 215 %right '%'
 216 %right UNARY
 217 %right '('
 218
 219 \f
 220 %%
 221
 222 start   :       exp
 223         |       type_exp
 224         ;
 225
 226 type_exp:       type
 227                         { pstate->push_new<type_operation> ($1); }
 228         ;
 229
 230 exp     :       '(' exp ')'
 231                         { }
 232         ;
 233
 234 /* Expressions, not including the comma operator.  */
 235 exp     :       '*' exp    %prec UNARY
 236                         { pstate->wrap<unop_ind_operation> (); }
 237         ;
 238
 239 exp     :       '&' exp    %prec UNARY
 240                         { pstate->wrap<unop_addr_operation> (); }
 241         ;
 242
 243 exp     :       '-' exp    %prec UNARY
 244                         { pstate->wrap<unary_neg_operation> (); }
 245         ;
 246
 247 exp     :       BOOL_NOT exp    %prec UNARY
 248                         { pstate->wrap<unary_logical_not_operation> (); }
 249         ;
 250
 251 exp     :       '~' exp    %prec UNARY
 252                         { pstate->wrap<unary_complement_operation> (); }
 253         ;
 254
 255 exp     :       SIZEOF exp       %prec UNARY
 256                         { pstate->wrap<unop_sizeof_operation> (); }
 257         ;
 258
 259 exp     :       KIND '(' exp ')'       %prec UNARY
 260                         { pstate->wrap<fortran_kind_operation> (); }
 261         ;
 262
 263 /* No more explicit array operators, we treat everything in F77 as
 264    a function call.  The disambiguation as to whether we are
 265    doing a subscript operation or a function call is done
 266    later in eval.c.  */
 267
 268 exp     :       exp '('
 269                         { pstate->start_arglist (); }
 270                 arglist ')'
 271                         {
 272                           std::vector<operation_up> args
 273                             = pstate->pop_vector (pstate->end_arglist ());
 274                           pstate->push_new<fortran_undetermined>
 275                             (pstate->pop (), std::move (args));
 276                         }
 277         ;
 278
 279 exp     :       UNOP_INTRINSIC '(' exp ')'
 280                         {
 281                           wrap_unop_intrinsic ($1);
 282                         }
 283         ;
 284
 285 exp     :       BINOP_INTRINSIC '(' exp ',' exp ')'
 286                         {
 287                           wrap_binop_intrinsic ($1);
 288                         }
 289         ;
 290
 291 exp     :       UNOP_OR_BINOP_INTRINSIC '('
 292                         { pstate->start_arglist (); }
 293                 arglist ')'
 294                         {
 295                           const int n = pstate->end_arglist ();
 296
 297                           switch (n)
 298                             {
 299                             case 1:
 300                               wrap_unop_intrinsic ($1);
 301                               break;
 302                             case 2:
 303                               wrap_binop_intrinsic ($1);
 304                               break;
 305                             default:
 306                               gdb_assert_not_reached
 307                                 ("wrong number of arguments for intrinsics");
 308                             }
 309                         }
 310
 311 exp     :       UNOP_OR_BINOP_OR_TERNOP_INTRINSIC '('
 312                         { pstate->start_arglist (); }
 313                 arglist ')'
 314                         {
 315                           const int n = pstate->end_arglist ();
 316
 317                           switch (n)
 318                             {
 319                             case 1:
 320                               wrap_unop_intrinsic ($1);
 321                               break;
 322                             case 2:
 323                               wrap_binop_intrinsic ($1);
 324                               break;
 325                             case 3:
 326                               wrap_ternop_intrinsic ($1);
 327                               break;
 328                             default:
 329                               gdb_assert_not_reached
 330                                 ("wrong number of arguments for intrinsics");
 331                             }
 332                         }
 333         ;
 334
 335 arglist :
 336         ;
 337
 338 arglist :       exp
 339                         { pstate->arglist_len = 1; }
 340         ;
 341
 342 arglist :       subrange
 343                         { pstate->arglist_len = 1; }
 344         ;
 345
 346 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 347                         { pstate->arglist_len++; }
 348         ;
 349
 350 arglist :       arglist ',' subrange   %prec ABOVE_COMMA
 351                         { pstate->arglist_len++; }
 352         ;
 353
 354 /* There are four sorts of subrange types in F90.  */
 355
 356 subrange:       exp ':' exp     %prec ABOVE_COMMA
 357                         {
 358                           operation_up high = pstate->pop ();
 359                           operation_up low = pstate->pop ();
 360                           pstate->push_new<fortran_range_operation>
 361                             (RANGE_STANDARD, std::move (low),
 362                              std::move (high), operation_up ());
 363                         }
 364         ;
 365
 366 subrange:       exp ':' %prec ABOVE_COMMA
 367                         {
 368                           operation_up low = pstate->pop ();
 369                           pstate->push_new<fortran_range_operation>
 370                             (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
 371                              operation_up (), operation_up ());
 372                         }
 373         ;
 374
 375 subrange:       ':' exp %prec ABOVE_COMMA
 376                         {
 377                           operation_up high = pstate->pop ();
 378                           pstate->push_new<fortran_range_operation>
 379                             (RANGE_LOW_BOUND_DEFAULT, operation_up (),
 380                              std::move (high), operation_up ());
 381                         }
 382         ;
 383
 384 subrange:       ':'     %prec ABOVE_COMMA
 385                         {
 386                           pstate->push_new<fortran_range_operation>
 387                             (RANGE_LOW_BOUND_DEFAULT
 388                              | RANGE_HIGH_BOUND_DEFAULT,
 389                              operation_up (), operation_up (),
 390                              operation_up ());
 391                         }
 392         ;
 393
 394 /* And each of the four subrange types can also have a stride.  */
 395 subrange:       exp ':' exp ':' exp     %prec ABOVE_COMMA
 396                         {
 397                           operation_up stride = pstate->pop ();
 398                           operation_up high = pstate->pop ();
 399                           operation_up low = pstate->pop ();
 400                           pstate->push_new<fortran_range_operation>
 401                             (RANGE_STANDARD | RANGE_HAS_STRIDE,
 402                              std::move (low), std::move (high),
 403                              std::move (stride));
 404                         }
 405         ;
 406
 407 subrange:       exp ':' ':' exp %prec ABOVE_COMMA
 408                         {
 409                           operation_up stride = pstate->pop ();
 410                           operation_up low = pstate->pop ();
 411                           pstate->push_new<fortran_range_operation>
 412                             (RANGE_HIGH_BOUND_DEFAULT
 413                              | RANGE_HAS_STRIDE,
 414                              std::move (low), operation_up (),
 415                              std::move (stride));
 416                         }
 417         ;
 418
 419 subrange:       ':' exp ':' exp %prec ABOVE_COMMA
 420                         {
 421                           operation_up stride = pstate->pop ();
 422                           operation_up high = pstate->pop ();
 423                           pstate->push_new<fortran_range_operation>
 424                             (RANGE_LOW_BOUND_DEFAULT
 425                              | RANGE_HAS_STRIDE,
 426                              operation_up (), std::move (high),
 427                              std::move (stride));
 428                         }
 429         ;
 430
 431 subrange:       ':' ':' exp     %prec ABOVE_COMMA
 432                         {
 433                           operation_up stride = pstate->pop ();
 434                           pstate->push_new<fortran_range_operation>
 435                             (RANGE_LOW_BOUND_DEFAULT
 436                              | RANGE_HIGH_BOUND_DEFAULT
 437                              | RANGE_HAS_STRIDE,
 438                              operation_up (), operation_up (),
 439                              std::move (stride));
 440                         }
 441         ;
 442
 443 complexnum:     exp ',' exp
 444                         { }
 445         ;
 446
 447 exp     :       '(' complexnum ')'
 448                         {
 449                           operation_up rhs = pstate->pop ();
 450                           operation_up lhs = pstate->pop ();
 451                           pstate->push_new<complex_operation>
 452                             (std::move (lhs), std::move (rhs),
 453                              parse_f_type (pstate)->builtin_complex_s16);
 454                         }
 455         ;
 456
 457 exp     :       '(' type ')' exp  %prec UNARY
 458                         {
 459                           pstate->push_new<unop_cast_operation>
 460                             (pstate->pop (), $2);
 461                         }
 462         ;
 463
 464 exp     :       exp '%' name
 465                         {
 466                           pstate->push_new<fortran_structop_operation>
 467                             (pstate->pop (), copy_name ($3));
 468                         }
 469         ;
 470
 471 exp     :       exp '%' name COMPLETE
 472                         {
 473                           structop_base_operation *op
 474                             = new fortran_structop_operation (pstate->pop (),
 475                                                               copy_name ($3));
 476                           pstate->mark_struct_expression (op);
 477                           pstate->push (operation_up (op));
 478                         }
 479         ;
 480
 481 exp     :       exp '%' COMPLETE
 482                         {
 483                           structop_base_operation *op
 484                             = new fortran_structop_operation (pstate->pop (),
 485                                                               "");
 486                           pstate->mark_struct_expression (op);
 487                           pstate->push (operation_up (op));
 488                         }
 489         ;
 490
 491 /* Binary operators in order of decreasing precedence.  */
 492
 493 exp     :       exp '@' exp
 494                         { pstate->wrap2<repeat_operation> (); }
 495         ;
 496
 497 exp     :       exp STARSTAR exp
 498                         { pstate->wrap2<exp_operation> (); }
 499         ;
 500
 501 exp     :       exp '*' exp
 502                         { pstate->wrap2<mul_operation> (); }
 503         ;
 504
 505 exp     :       exp '/' exp
 506                         { pstate->wrap2<div_operation> (); }
 507         ;
 508
 509 exp     :       exp '+' exp
 510                         { pstate->wrap2<add_operation> (); }
 511         ;
 512
 513 exp     :       exp '-' exp
 514                         { pstate->wrap2<sub_operation> (); }
 515         ;
 516
 517 exp     :       exp LSH exp
 518                         { pstate->wrap2<lsh_operation> (); }
 519         ;
 520
 521 exp     :       exp RSH exp
 522                         { pstate->wrap2<rsh_operation> (); }
 523         ;
 524
 525 exp     :       exp EQUAL exp
 526                         { pstate->wrap2<equal_operation> (); }
 527         ;
 528
 529 exp     :       exp NOTEQUAL exp
 530                         { pstate->wrap2<notequal_operation> (); }
 531         ;
 532
 533 exp     :       exp LEQ exp
 534                         { pstate->wrap2<leq_operation> (); }
 535         ;
 536
 537 exp     :       exp GEQ exp
 538                         { pstate->wrap2<geq_operation> (); }
 539         ;
 540
 541 exp     :       exp LESSTHAN exp
 542                         { pstate->wrap2<less_operation> (); }
 543         ;
 544
 545 exp     :       exp GREATERTHAN exp
 546                         { pstate->wrap2<gtr_operation> (); }
 547         ;
 548
 549 exp     :       exp '&' exp
 550                         { pstate->wrap2<bitwise_and_operation> (); }
 551         ;
 552
 553 exp     :       exp '^' exp
 554                         { pstate->wrap2<bitwise_xor_operation> (); }
 555         ;
 556
 557 exp     :       exp '|' exp
 558                         { pstate->wrap2<bitwise_ior_operation> (); }
 559         ;
 560
 561 exp     :       exp BOOL_AND exp
 562                         { pstate->wrap2<logical_and_operation> (); }
 563         ;
 564
 565
 566 exp     :       exp BOOL_OR exp
 567                         { pstate->wrap2<logical_or_operation> (); }
 568         ;
 569
 570 exp     :       exp '=' exp
 571                         { pstate->wrap2<assign_operation> (); }
 572         ;
 573
 574 exp     :       exp ASSIGN_MODIFY exp
 575                         {
 576                           operation_up rhs = pstate->pop ();
 577                           operation_up lhs = pstate->pop ();
 578                           pstate->push_new<assign_modify_operation>
 579                             ($2, std::move (lhs), std::move (rhs));
 580                         }
 581         ;
 582
 583 exp     :       INT
 584                         {
 585                           pstate->push_new<long_const_operation>
 586                             ($1.type, $1.val);
 587                         }
 588         ;
 589
 590 exp     :       NAME_OR_INT
 591                         { YYSTYPE val;
 592                           parse_number (pstate, $1.stoken.ptr,
 593                                         $1.stoken.length, 0, &val);
 594                           pstate->push_new<long_const_operation>
 595                             (val.typed_val.type,
 596                              val.typed_val.val);
 597                         }
 598         ;
 599
 600 exp     :       FLOAT
 601                         {
 602                           float_data data;
 603                           std::copy (std::begin ($1.val), std::end ($1.val),
 604                                      std::begin (data));
 605                           pstate->push_new<float_const_operation> ($1.type, data);
 606                         }
 607         ;
 608
 609 exp     :       variable
 610         ;
 611
 612 exp     :       DOLLAR_VARIABLE
 613                         { pstate->push_dollar ($1); }
 614         ;
 615
 616 exp     :       SIZEOF '(' type ')'     %prec UNARY
 617                         {
 618                           $3 = check_typedef ($3);
 619                           pstate->push_new<long_const_operation>
 620                             (parse_f_type (pstate)->builtin_integer,
 621                              TYPE_LENGTH ($3));
 622                         }
 623         ;
 624
 625 exp     :       BOOLEAN_LITERAL
 626                         { pstate->push_new<bool_operation> ($1); }
 627         ;
 628
 629 exp     :       STRING_LITERAL
 630                         {
 631                           pstate->push_new<string_operation>
 632                             (copy_name ($1));
 633                         }
 634         ;
 635
 636 variable:       name_not_typename
 637                         { struct block_symbol sym = $1.sym;
 638                           std::string name = copy_name ($1.stoken);
 639                           pstate->push_symbol (name.c_str (), sym);
 640                         }
 641         ;
 642
 643
 644 type    :       ptype
 645         ;
 646
 647 ptype   :       typebase
 648         |       typebase abs_decl
 649                 {
 650                   /* This is where the interesting stuff happens.  */
 651                   int done = 0;
 652                   int array_size;
 653                   struct type *follow_type = $1;
 654                   struct type *range_type;
 655
 656                   while (!done)
 657                     switch (type_stack->pop ())
 658                       {
 659                       case tp_end:
 660                         done = 1;
 661                         break;
 662                       case tp_pointer:
 663                         follow_type = lookup_pointer_type (follow_type);
 664                         break;
 665                       case tp_reference:
 666                         follow_type = lookup_lvalue_reference_type (follow_type);
 667                         break;
 668                       case tp_array:
 669                         array_size = type_stack->pop_int ();
 670                         if (array_size != -1)
 671                           {
 672                             range_type =
 673                               create_static_range_type ((struct type *) NULL,
 674                                                         parse_f_type (pstate)
 675                                                         ->builtin_integer,
 676                                                         0, array_size - 1);
 677                             follow_type =
 678                               create_array_type ((struct type *) NULL,
 679                                                  follow_type, range_type);
 680                           }
 681                         else
 682                           follow_type = lookup_pointer_type (follow_type);
 683                         break;
 684                       case tp_function:
 685                         follow_type = lookup_function_type (follow_type);
 686                         break;
 687                       case tp_kind:
 688                         {
 689                           int kind_val = type_stack->pop_int ();
 690                           follow_type
 691                             = convert_to_kind_type (follow_type, kind_val);
 692                         }
 693                         break;
 694                       }
 695                   $$ = follow_type;
 696                 }
 697         ;
 698
 699 abs_decl:       '*'
 700                         { type_stack->push (tp_pointer); $$ = 0; }
 701         |       '*' abs_decl
 702                         { type_stack->push (tp_pointer); $$ = $2; }
 703         |       '&'
 704                         { type_stack->push (tp_reference); $$ = 0; }
 705         |       '&' abs_decl
 706                         { type_stack->push (tp_reference); $$ = $2; }
 707         |       direct_abs_decl
 708         ;
 709
 710 direct_abs_decl: '(' abs_decl ')'
 711                         { $$ = $2; }
 712         |       '(' KIND '=' INT ')'
 713                         { push_kind_type ($4.val, $4.type); }
 714         |       '*' INT
 715                         { push_kind_type ($2.val, $2.type); }
 716         |       direct_abs_decl func_mod
 717                         { type_stack->push (tp_function); }
 718         |       func_mod
 719                         { type_stack->push (tp_function); }
 720         ;
 721
 722 func_mod:       '(' ')'
 723                         { $$ = 0; }
 724         |       '(' nonempty_typelist ')'
 725                         { free ($2); $$ = 0; }
 726         ;
 727
 728 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 729         :       TYPENAME
 730                         { $$ = $1.type; }
 731         |       INT_S1_KEYWORD
 732                         { $$ = parse_f_type (pstate)->builtin_integer_s1; }
 733         |       INT_S2_KEYWORD
 734                         { $$ = parse_f_type (pstate)->builtin_integer_s2; }
 735         |       INT_KEYWORD
 736                         { $$ = parse_f_type (pstate)->builtin_integer; }
 737         |       INT_S4_KEYWORD
 738                         { $$ = parse_f_type (pstate)->builtin_integer; }
 739         |       INT_S8_KEYWORD
 740                         { $$ = parse_f_type (pstate)->builtin_integer_s8; }
 741         |       CHARACTER
 742                         { $$ = parse_f_type (pstate)->builtin_character; }
 743         |       LOGICAL_S1_KEYWORD
 744                         { $$ = parse_f_type (pstate)->builtin_logical_s1; }
 745         |       LOGICAL_S2_KEYWORD
 746                         { $$ = parse_f_type (pstate)->builtin_logical_s2; }
 747         |       LOGICAL_KEYWORD
 748                         { $$ = parse_f_type (pstate)->builtin_logical; }
 749         |       LOGICAL_S4_KEYWORD
 750                         { $$ = parse_f_type (pstate)->builtin_logical; }
 751         |       LOGICAL_S8_KEYWORD
 752                         { $$ = parse_f_type (pstate)->builtin_logical_s8; }
 753         |       REAL_KEYWORD
 754                         { $$ = parse_f_type (pstate)->builtin_real; }
 755         |       REAL_S4_KEYWORD
 756                         { $$ = parse_f_type (pstate)->builtin_real; }
 757         |       REAL_S8_KEYWORD
 758                         { $$ = parse_f_type (pstate)->builtin_real_s8; }
 759         |       REAL_S16_KEYWORD
 760                         { $$ = parse_f_type (pstate)->builtin_real_s16; }
 761         |       COMPLEX_KEYWORD
 762                         { $$ = parse_f_type (pstate)->builtin_complex; }
 763         |       COMPLEX_S4_KEYWORD
 764                         { $$ = parse_f_type (pstate)->builtin_complex; }
 765         |       COMPLEX_S8_KEYWORD
 766                         { $$ = parse_f_type (pstate)->builtin_complex_s8; }
 767         |       COMPLEX_S16_KEYWORD
 768                         { $$ = parse_f_type (pstate)->builtin_complex_s16; }
 769         |       SINGLE PRECISION
 770                         { $$ = parse_f_type (pstate)->builtin_real;}
 771         |       DOUBLE PRECISION
 772                         { $$ = parse_f_type (pstate)->builtin_real_s8;}
 773         |       SINGLE COMPLEX_KEYWORD
 774                         { $$ = parse_f_type (pstate)->builtin_complex;}
 775         |       DOUBLE COMPLEX_KEYWORD
 776                         { $$ = parse_f_type (pstate)->builtin_complex_s8;}
 777         ;
 778
 779 nonempty_typelist
 780         :       type
 781                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 782                   $<ivec>$[0] = 1;      /* Number of types in vector */
 783                   $$[1] = $1;
 784                 }
 785         |       nonempty_typelist ',' type
 786                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 787                   $$ = (struct type **) realloc ((char *) $1, len);
 788                   $$[$<ivec>$[0]] = $3;
 789                 }
 790         ;
 791
 792 name
 793         :       NAME
 794                 { $$ = $1.stoken; }
 795         |       TYPENAME
 796                 { $$ = $1.stoken; }
 797         ;
 798
 799 name_not_typename :     NAME
 800 /* These would be useful if name_not_typename was useful, but it is just
 801    a fake for "variable", so these cause reduce/reduce conflicts because
 802    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 803    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 804    context where only a name could occur, this might be useful.
 805         |       NAME_OR_INT
 806    */
 807         ;
 808
 809 %%
 810
 811 /* Called to match intrinsic function calls with one argument to their
 812    respective implementation and push the operation.  */
 813
 814 static void
 815 wrap_unop_intrinsic (exp_opcode code)
 816 {
 817   switch (code)
 818     {
 819     case UNOP_ABS:
 820       pstate->wrap<fortran_abs_operation> ();
 821       break;
 822     case FORTRAN_FLOOR:
 823       pstate->wrap<fortran_floor_operation_1arg> ();
 824       break;
 825     case FORTRAN_CEILING:
 826       pstate->wrap<fortran_ceil_operation_1arg> ();
 827       break;
 828     case UNOP_FORTRAN_ALLOCATED:
 829       pstate->wrap<fortran_allocated_operation> ();
 830       break;
 831     case UNOP_FORTRAN_RANK:
 832       pstate->wrap<fortran_rank_operation> ();
 833       break;
 834     case UNOP_FORTRAN_SHAPE:
 835       pstate->wrap<fortran_array_shape_operation> ();
 836       break;
 837     case UNOP_FORTRAN_LOC:
 838       pstate->wrap<fortran_loc_operation> ();
 839       break;
 840     case FORTRAN_ASSOCIATED:
 841       pstate->wrap<fortran_associated_1arg> ();
 842       break;
 843     case FORTRAN_ARRAY_SIZE:
 844       pstate->wrap<fortran_array_size_1arg> ();
 845       break;
 846     case FORTRAN_CMPLX:
 847       pstate->wrap<fortran_cmplx_operation_1arg> ();
 848       break;
 849     case FORTRAN_LBOUND:
 850     case FORTRAN_UBOUND:
 851       pstate->push_new<fortran_bound_1arg> (code, pstate->pop ());
 852       break;
 853     default:
 854       gdb_assert_not_reached ("unhandled intrinsic");
 855     }
 856 }
 857
 858 /* Called to match intrinsic function calls with two arguments to their
 859    respective implementation and push the operation.  */
 860
 861 static void
 862 wrap_binop_intrinsic (exp_opcode code)
 863 {
 864   switch (code)
 865     {
 866     case FORTRAN_FLOOR:
 867       fortran_wrap2_kind<fortran_floor_operation_2arg>
 868         (parse_f_type (pstate)->builtin_integer);
 869       break;
 870     case FORTRAN_CEILING:
 871       fortran_wrap2_kind<fortran_ceil_operation_2arg>
 872         (parse_f_type (pstate)->builtin_integer);
 873       break;
 874     case BINOP_MOD:
 875       pstate->wrap2<fortran_mod_operation> ();
 876       break;
 877     case BINOP_FORTRAN_MODULO:
 878       pstate->wrap2<fortran_modulo_operation> ();
 879       break;
 880     case FORTRAN_CMPLX:
 881       pstate->wrap2<fortran_cmplx_operation_2arg> ();
 882       break;
 883     case FORTRAN_ASSOCIATED:
 884       pstate->wrap2<fortran_associated_2arg> ();
 885       break;
 886     case FORTRAN_ARRAY_SIZE:
 887       pstate->wrap2<fortran_array_size_2arg> ();
 888       break;
 889     case FORTRAN_LBOUND:
 890     case FORTRAN_UBOUND:
 891       {
 892         operation_up arg2 = pstate->pop ();
 893         operation_up arg1 = pstate->pop ();
 894         pstate->push_new<fortran_bound_2arg> (code, std::move (arg1),
 895                                               std::move (arg2));
 896       }
 897       break;
 898     default:
 899       gdb_assert_not_reached ("unhandled intrinsic");
 900     }
 901 }
 902
 903 /* Called to match intrinsic function calls with three arguments to their
 904    respective implementation and push the operation.  */
 905
 906 static void
 907 wrap_ternop_intrinsic (exp_opcode code)
 908 {
 909   switch (code)
 910     {
 911     case FORTRAN_LBOUND:
 912     case FORTRAN_UBOUND:
 913       {
 914         operation_up kind_arg = pstate->pop ();
 915         operation_up arg2 = pstate->pop ();
 916         operation_up arg1 = pstate->pop ();
 917
 918         value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
 919                                          EVAL_AVOID_SIDE_EFFECTS);
 920         gdb_assert (val != nullptr);
 921
 922         type *follow_type
 923           = convert_to_kind_type (parse_f_type (pstate)->builtin_integer,
 924                                   value_as_long (val));
 925
 926         pstate->push_new<fortran_bound_3arg> (code, std::move (arg1),
 927                                               std::move (arg2), follow_type);
 928       }
 929       break;
 930     case FORTRAN_ARRAY_SIZE:
 931       fortran_wrap3_kind<fortran_array_size_3arg>
 932         (parse_f_type (pstate)->builtin_integer);
 933       break;
 934     case FORTRAN_CMPLX:
 935       fortran_wrap3_kind<fortran_cmplx_operation_3arg>
 936         (parse_f_type (pstate)->builtin_complex);
 937       break;
 938     default:
 939       gdb_assert_not_reached ("unhandled intrinsic");
 940     }
 941 }
 942
 943 /* A helper that pops two operations (similar to wrap2), evaluates the last one
 944    assuming it is a kind parameter, and wraps them in some other operation
 945    pushing it to the stack.  */
 946
 947 template<typename T>
 948 static void
 949 fortran_wrap2_kind (type *base_type)
 950 {
 951   operation_up kind_arg = pstate->pop ();
 952   operation_up arg = pstate->pop ();
 953
 954   value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
 955                                    EVAL_AVOID_SIDE_EFFECTS);
 956   gdb_assert (val != nullptr);
 957
 958   type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
 959
 960   pstate->push_new<T> (std::move (arg), follow_type);
 961 }
 962
 963 /* A helper that pops three operations, evaluates the last one assuming it is a
 964    kind parameter, and wraps them in some other operation pushing it to the
 965    stack.  */
 966
 967 template<typename T>
 968 static void
 969 fortran_wrap3_kind (type *base_type)
 970 {
 971   operation_up kind_arg = pstate->pop ();
 972   operation_up arg2 = pstate->pop ();
 973   operation_up arg1 = pstate->pop ();
 974
 975   value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
 976                                    EVAL_AVOID_SIDE_EFFECTS);
 977   gdb_assert (val != nullptr);
 978
 979   type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
 980
 981   pstate->push_new<T> (std::move (arg1), std::move (arg2), follow_type);
 982 }
 983
 984 /* Take care of parsing a number (anything that starts with a digit).
 985    Set yylval and return the token type; update lexptr.
 986    LEN is the number of characters in it.  */
 987
 988 /*** Needs some error checking for the float case ***/
 989
 990 static int
 991 parse_number (struct parser_state *par_state,
 992               const char *p, int len, int parsed_float, YYSTYPE *putithere)
 993 {
 994   ULONGEST n = 0;
 995   ULONGEST prevn = 0;
 996   int c;
 997   int base = input_radix;
 998   int unsigned_p = 0;
 999   int long_p = 0;
1000   ULONGEST high_bit;
1001   struct type *signed_type;
1002   struct type *unsigned_type;
1003
1004   if (parsed_float)
1005     {
1006       /* It's a float since it contains a point or an exponent.  */
1007       /* [dD] is not understood as an exponent by parse_float,
1008          change it to 'e'.  */
1009       char *tmp, *tmp2;
1010
1011       tmp = xstrdup (p);
1012       for (tmp2 = tmp; *tmp2; ++tmp2)
1013         if (*tmp2 == 'd' || *tmp2 == 'D')
1014           *tmp2 = 'e';
1015
1016       /* FIXME: Should this use different types?  */
1017       putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
1018       bool parsed = parse_float (tmp, len,
1019                                  putithere->typed_val_float.type,
1020                                  putithere->typed_val_float.val);
1021       free (tmp);
1022       return parsed? FLOAT : ERROR;
1023     }
1024
1025   /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
1026   if (p[0] == '0' && len > 1)
1027     switch (p[1])
1028       {
1029       case 'x':
1030       case 'X':
1031         if (len >= 3)
1032           {
1033             p += 2;
1034             base = 16;
1035             len -= 2;
1036           }
1037         break;
1038
1039       case 't':
1040       case 'T':
1041       case 'd':
1042       case 'D':
1043         if (len >= 3)
1044           {
1045             p += 2;
1046             base = 10;
1047             len -= 2;
1048           }
1049         break;
1050
1051       default:
1052         base = 8;
1053         break;
1054       }
1055
1056   while (len-- > 0)
1057     {
1058       c = *p++;
1059       if (isupper (c))
1060         c = tolower (c);
1061       if (len == 0 && c == 'l')
1062         long_p = 1;
1063       else if (len == 0 && c == 'u')
1064         unsigned_p = 1;
1065       else
1066         {
1067           int i;
1068           if (c >= '0' && c <= '9')
1069             i = c - '0';
1070           else if (c >= 'a' && c <= 'f')
1071             i = c - 'a' + 10;
1072           else
1073             return ERROR;       /* Char not a digit */
1074           if (i >= base)
1075             return ERROR;               /* Invalid digit in this base */
1076           n *= base;
1077           n += i;
1078         }
1079       /* Portably test for overflow (only works for nonzero values, so make
1080          a second check for zero).  */
1081       if ((prevn >= n) && n != 0)
1082         unsigned_p=1;           /* Try something unsigned */
1083       /* If range checking enabled, portably test for unsigned overflow.  */
1084       if (RANGE_CHECK && n != 0)
1085         {
1086           if ((unsigned_p && prevn >= n))
1087             range_error (_("Overflow on numeric constant."));
1088         }
1089       prevn = n;
1090     }
1091
1092   /* If the number is too big to be an int, or it's got an l suffix
1093      then it's a long.  Work out if this has to be a long by
1094      shifting right and seeing if anything remains, and the
1095      target int size is different to the target long size.
1096
1097      In the expression below, we could have tested
1098      (n >> gdbarch_int_bit (parse_gdbarch))
1099      to see if it was zero,
1100      but too many compilers warn about that, when ints and longs
1101      are the same size.  So we shift it twice, with fewer bits
1102      each time, for the same result.  */
1103
1104   if ((gdbarch_int_bit (par_state->gdbarch ())
1105        != gdbarch_long_bit (par_state->gdbarch ())
1106        && ((n >> 2)
1107            >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
1108                                                             shift warning */
1109       || long_p)
1110     {
1111       high_bit = ((ULONGEST)1)
1112       << (gdbarch_long_bit (par_state->gdbarch ())-1);
1113       unsigned_type = parse_type (par_state)->builtin_unsigned_long;
1114       signed_type = parse_type (par_state)->builtin_long;
1115     }
1116   else
1117     {
1118       high_bit =
1119         ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
1120       unsigned_type = parse_type (par_state)->builtin_unsigned_int;
1121       signed_type = parse_type (par_state)->builtin_int;
1122     }
1123
1124   putithere->typed_val.val = n;
1125
1126   /* If the high bit of the worked out type is set then this number
1127      has to be unsigned.  */
1128
1129   if (unsigned_p || (n & high_bit))
1130     putithere->typed_val.type = unsigned_type;
1131   else
1132     putithere->typed_val.type = signed_type;
1133
1134   return INT;
1135 }
1136
1137 /* Called to setup the type stack when we encounter a '(kind=N)' type
1138    modifier, performs some bounds checking on 'N' and then pushes this to
1139    the type stack followed by the 'tp_kind' marker.  */
1140 static void
1141 push_kind_type (LONGEST val, struct type *type)
1142 {
1143   int ival;
1144
1145   if (type->is_unsigned ())
1146     {
1147       ULONGEST uval = static_cast <ULONGEST> (val);
1148       if (uval > INT_MAX)
1149         error (_("kind value out of range"));
1150       ival = static_cast <int> (uval);
1151     }
1152   else
1153     {
1154       if (val > INT_MAX || val < 0)
1155         error (_("kind value out of range"));
1156       ival = static_cast <int> (val);
1157     }
1158
1159   type_stack->push (ival);
1160   type_stack->push (tp_kind);
1161 }
1162
1163 /* Called when a type has a '(kind=N)' modifier after it, for example
1164    'character(kind=1)'.  The BASETYPE is the type described by 'character'
1165    in our example, and KIND is the integer '1'.  This function returns a
1166    new type that represents the basetype of a specific kind.  */
1167 static struct type *
1168 convert_to_kind_type (struct type *basetype, int kind)
1169 {
1170   if (basetype == parse_f_type (pstate)->builtin_character)
1171     {
1172       /* Character of kind 1 is a special case, this is the same as the
1173          base character type.  */
1174       if (kind == 1)
1175         return parse_f_type (pstate)->builtin_character;
1176     }
1177   else if (basetype == parse_f_type (pstate)->builtin_complex)
1178     {
1179       if (kind == 4)
1180         return parse_f_type (pstate)->builtin_complex;
1181       else if (kind == 8)
1182         return parse_f_type (pstate)->builtin_complex_s8;
1183       else if (kind == 16)
1184         return parse_f_type (pstate)->builtin_complex_s16;
1185     }
1186   else if (basetype == parse_f_type (pstate)->builtin_real)
1187     {
1188       if (kind == 4)
1189         return parse_f_type (pstate)->builtin_real;
1190       else if (kind == 8)
1191         return parse_f_type (pstate)->builtin_real_s8;
1192       else if (kind == 16)
1193         return parse_f_type (pstate)->builtin_real_s16;
1194     }
1195   else if (basetype == parse_f_type (pstate)->builtin_logical)
1196     {
1197       if (kind == 1)
1198         return parse_f_type (pstate)->builtin_logical_s1;
1199       else if (kind == 2)
1200         return parse_f_type (pstate)->builtin_logical_s2;
1201       else if (kind == 4)
1202         return parse_f_type (pstate)->builtin_logical;
1203       else if (kind == 8)
1204         return parse_f_type (pstate)->builtin_logical_s8;
1205     }
1206   else if (basetype == parse_f_type (pstate)->builtin_integer)
1207     {
1208       if (kind == 1)
1209         return parse_f_type (pstate)->builtin_integer_s1;
1210       else if (kind == 2)
1211         return parse_f_type (pstate)->builtin_integer_s2;
1212       else if (kind == 4)
1213         return parse_f_type (pstate)->builtin_integer;
1214       else if (kind == 8)
1215         return parse_f_type (pstate)->builtin_integer_s8;
1216     }
1217
1218   error (_("unsupported kind %d for type %s"),
1219          kind, TYPE_SAFE_NAME (basetype));
1220
1221   /* Should never get here.  */
1222   return nullptr;
1223 }
1224
1225 struct token
1226 {
1227   /* The string to match against.  */
1228   const char *oper;
1229
1230   /* The lexer token to return.  */
1231   int token;
1232
1233   /* The expression opcode to embed within the token.  */
1234   enum exp_opcode opcode;
1235
1236   /* When this is true the string in OPER is matched exactly including
1237      case, when this is false OPER is matched case insensitively.  */
1238   bool case_sensitive;
1239 };
1240
1241 /* List of Fortran operators.  */
1242
1243 static const struct token fortran_operators[] =
1244 {
1245   { ".and.", BOOL_AND, OP_NULL, false },
1246   { ".or.", BOOL_OR, OP_NULL, false },
1247   { ".not.", BOOL_NOT, OP_NULL, false },
1248   { ".eq.", EQUAL, OP_NULL, false },
1249   { ".eqv.", EQUAL, OP_NULL, false },
1250   { ".neqv.", NOTEQUAL, OP_NULL, false },
1251   { ".xor.", NOTEQUAL, OP_NULL, false },
1252   { "==", EQUAL, OP_NULL, false },
1253   { ".ne.", NOTEQUAL, OP_NULL, false },
1254   { "/=", NOTEQUAL, OP_NULL, false },
1255   { ".le.", LEQ, OP_NULL, false },
1256   { "<=", LEQ, OP_NULL, false },
1257   { ".ge.", GEQ, OP_NULL, false },
1258   { ">=", GEQ, OP_NULL, false },
1259   { ".gt.", GREATERTHAN, OP_NULL, false },
1260   { ">", GREATERTHAN, OP_NULL, false },
1261   { ".lt.", LESSTHAN, OP_NULL, false },
1262   { "<", LESSTHAN, OP_NULL, false },
1263   { "**", STARSTAR, BINOP_EXP, false },
1264 };
1265
1266 /* Holds the Fortran representation of a boolean, and the integer value we
1267    substitute in when one of the matching strings is parsed.  */
1268 struct f77_boolean_val
1269 {
1270   /* The string representing a Fortran boolean.  */
1271   const char *name;
1272
1273   /* The integer value to replace it with.  */
1274   int value;
1275 };
1276
1277 /* The set of Fortran booleans.  These are matched case insensitively.  */
1278 static const struct f77_boolean_val boolean_values[]  =
1279 {
1280   { ".true.", 1 },
1281   { ".false.", 0 }
1282 };
1283
1284 static const token f_keywords[] =
1285 {
1286   /* Historically these have always been lowercase only in GDB.  */
1287   { "character", CHARACTER, OP_NULL, true },
1288   { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1289   { "complex_4", COMPLEX_S4_KEYWORD, OP_NULL, true },
1290   { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1291   { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1292   { "integer_1", INT_S1_KEYWORD, OP_NULL, true },
1293   { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1294   { "integer_4", INT_S4_KEYWORD, OP_NULL, true },
1295   { "integer", INT_KEYWORD, OP_NULL, true },
1296   { "integer_8", INT_S8_KEYWORD, OP_NULL, true },
1297   { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1298   { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1299   { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1300   { "logical_4", LOGICAL_S4_KEYWORD, OP_NULL, true },
1301   { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1302   { "real", REAL_KEYWORD, OP_NULL, true },
1303   { "real_4", REAL_S4_KEYWORD, OP_NULL, true },
1304   { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1305   { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1306   { "sizeof", SIZEOF, OP_NULL, true },
1307   { "single", SINGLE, OP_NULL, true },
1308   { "double", DOUBLE, OP_NULL, true },
1309   { "precision", PRECISION, OP_NULL, true },
1310   /* The following correspond to actual functions in Fortran and are case
1311      insensitive.  */
1312   { "kind", KIND, OP_NULL, false },
1313   { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1314   { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1315   { "floor", UNOP_OR_BINOP_INTRINSIC, FORTRAN_FLOOR, false },
1316   { "ceiling", UNOP_OR_BINOP_INTRINSIC, FORTRAN_CEILING, false },
1317   { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1318   { "cmplx", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_CMPLX, false },
1319   { "lbound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_LBOUND, false },
1320   { "ubound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_UBOUND, false },
1321   { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1322   { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1323   { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1324   { "size", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1325   { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
1326   { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false },
1327 };
1328
1329 /* Implementation of a dynamically expandable buffer for processing input
1330    characters acquired through lexptr and building a value to return in
1331    yylval.  Ripped off from ch-exp.y */
1332
1333 static char *tempbuf;           /* Current buffer contents */
1334 static int tempbufsize;         /* Size of allocated buffer */
1335 static int tempbufindex;        /* Current index into buffer */
1336
1337 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
1338
1339 #define CHECKBUF(size) \
1340   do { \
1341     if (tempbufindex + (size) >= tempbufsize) \
1342       { \
1343         growbuf_by_size (size); \
1344       } \
1345   } while (0);
1346
1347
1348 /* Grow the static temp buffer if necessary, including allocating the
1349    first one on demand.  */
1350
1351 static void
1352 growbuf_by_size (int count)
1353 {
1354   int growby;
1355
1356   growby = std::max (count, GROWBY_MIN_SIZE);
1357   tempbufsize += growby;
1358   if (tempbuf == NULL)
1359     tempbuf = (char *) malloc (tempbufsize);
1360   else
1361     tempbuf = (char *) realloc (tempbuf, tempbufsize);
1362 }
1363
1364 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1365    string-literals.
1366
1367    Recognize a string literal.  A string literal is a nonzero sequence
1368    of characters enclosed in matching single quotes, except that
1369    a single character inside single quotes is a character literal, which
1370    we reject as a string literal.  To embed the terminator character inside
1371    a string, it is simply doubled (I.E. 'this''is''one''string') */
1372
1373 static int
1374 match_string_literal (void)
1375 {
1376   const char *tokptr = pstate->lexptr;
1377
1378   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1379     {
1380       CHECKBUF (1);
1381       if (*tokptr == *pstate->lexptr)
1382         {
1383           if (*(tokptr + 1) == *pstate->lexptr)
1384             tokptr++;
1385           else
1386             break;
1387         }
1388       tempbuf[tempbufindex++] = *tokptr;
1389     }
1390   if (*tokptr == '\0'                                   /* no terminator */
1391       || tempbufindex == 0)                             /* no string */
1392     return 0;
1393   else
1394     {
1395       tempbuf[tempbufindex] = '\0';
1396       yylval.sval.ptr = tempbuf;
1397       yylval.sval.length = tempbufindex;
1398       pstate->lexptr = ++tokptr;
1399       return STRING_LITERAL;
1400     }
1401 }
1402
1403 /* This is set if a NAME token appeared at the very end of the input
1404    string, with no whitespace separating the name from the EOF.  This
1405    is used only when parsing to do field name completion.  */
1406 static bool saw_name_at_eof;
1407
1408 /* This is set if the previously-returned token was a structure
1409    operator '%'.  */
1410 static bool last_was_structop;
1411
1412 /* Read one token, getting characters through lexptr.  */
1413
1414 static int
1415 yylex (void)
1416 {
1417   int c;
1418   int namelen;
1419   unsigned int token;
1420   const char *tokstart;
1421   bool saw_structop = last_was_structop;
1422
1423   last_was_structop = false;
1424
1425  retry:
1426
1427   pstate->prev_lexptr = pstate->lexptr;
1428
1429   tokstart = pstate->lexptr;
1430
1431   /* First of all, let us make sure we are not dealing with the
1432      special tokens .true. and .false. which evaluate to 1 and 0.  */
1433
1434   if (*pstate->lexptr == '.')
1435     {
1436       for (const auto &candidate : boolean_values)
1437         {
1438           if (strncasecmp (tokstart, candidate.name,
1439                            strlen (candidate.name)) == 0)
1440             {
1441               pstate->lexptr += strlen (candidate.name);
1442               yylval.lval = candidate.value;
1443               return BOOLEAN_LITERAL;
1444             }
1445         }
1446     }
1447
1448   /* See if it is a Fortran operator.  */
1449   for (const auto &candidate : fortran_operators)
1450     if (strncasecmp (tokstart, candidate.oper,
1451                      strlen (candidate.oper)) == 0)
1452       {
1453         gdb_assert (!candidate.case_sensitive);
1454         pstate->lexptr += strlen (candidate.oper);
1455         yylval.opcode = candidate.opcode;
1456         return candidate.token;
1457       }
1458
1459   switch (c = *tokstart)
1460     {
1461     case 0:
1462       if (saw_name_at_eof)
1463         {
1464           saw_name_at_eof = false;
1465           return COMPLETE;
1466         }
1467       else if (pstate->parse_completion && saw_structop)
1468         return COMPLETE;
1469       return 0;
1470
1471     case ' ':
1472     case '\t':
1473     case '\n':
1474       pstate->lexptr++;
1475       goto retry;
1476
1477     case '\'':
1478       token = match_string_literal ();
1479       if (token != 0)
1480         return (token);
1481       break;
1482
1483     case '(':
1484       paren_depth++;
1485       pstate->lexptr++;
1486       return c;
1487
1488     case ')':
1489       if (paren_depth == 0)
1490         return 0;
1491       paren_depth--;
1492       pstate->lexptr++;
1493       return c;
1494
1495     case ',':
1496       if (pstate->comma_terminates && paren_depth == 0)
1497         return 0;
1498       pstate->lexptr++;
1499       return c;
1500
1501     case '.':
1502       /* Might be a floating point number.  */
1503       if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1504         goto symbol;            /* Nope, must be a symbol.  */
1505       /* FALL THRU.  */
1506
1507     case '0':
1508     case '1':
1509     case '2':
1510     case '3':
1511     case '4':
1512     case '5':
1513     case '6':
1514     case '7':
1515     case '8':
1516     case '9':
1517       {
1518         /* It's a number.  */
1519         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1520         const char *p = tokstart;
1521         int hex = input_radix > 10;
1522
1523         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1524           {
1525             p += 2;
1526             hex = 1;
1527           }
1528         else if (c == '0' && (p[1]=='t' || p[1]=='T'
1529                               || p[1]=='d' || p[1]=='D'))
1530           {
1531             p += 2;
1532             hex = 0;
1533           }
1534
1535         for (;; ++p)
1536           {
1537             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1538               got_dot = got_e = 1;
1539             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1540               got_dot = got_d = 1;
1541             else if (!hex && !got_dot && *p == '.')
1542               got_dot = 1;
1543             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1544                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1545                      && (*p == '-' || *p == '+'))
1546               /* This is the sign of the exponent, not the end of the
1547                  number.  */
1548               continue;
1549             /* We will take any letters or digits.  parse_number will
1550                complain if past the radix, or if L or U are not final.  */
1551             else if ((*p < '0' || *p > '9')
1552                      && ((*p < 'a' || *p > 'z')
1553                          && (*p < 'A' || *p > 'Z')))
1554               break;
1555           }
1556         toktype = parse_number (pstate, tokstart, p - tokstart,
1557                                 got_dot|got_e|got_d,
1558                                 &yylval);
1559         if (toktype == ERROR)
1560           {
1561             char *err_copy = (char *) alloca (p - tokstart + 1);
1562
1563             memcpy (err_copy, tokstart, p - tokstart);
1564             err_copy[p - tokstart] = 0;
1565             error (_("Invalid number \"%s\"."), err_copy);
1566           }
1567         pstate->lexptr = p;
1568         return toktype;
1569       }
1570
1571     case '%':
1572       last_was_structop = true;
1573       /* Fall through.  */
1574     case '+':
1575     case '-':
1576     case '*':
1577     case '/':
1578     case '|':
1579     case '&':
1580     case '^':
1581     case '~':
1582     case '!':
1583     case '@':
1584     case '<':
1585     case '>':
1586     case '[':
1587     case ']':
1588     case '?':
1589     case ':':
1590     case '=':
1591     case '{':
1592     case '}':
1593     symbol:
1594       pstate->lexptr++;
1595       return c;
1596     }
1597
1598   if (!(c == '_' || c == '$' || c ==':'
1599         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1600     /* We must have come across a bad character (e.g. ';').  */
1601     error (_("Invalid character '%c' in expression."), c);
1602
1603   namelen = 0;
1604   for (c = tokstart[namelen];
1605        (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1606         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1607        c = tokstart[++namelen]);
1608
1609   /* The token "if" terminates the expression and is NOT
1610      removed from the input stream.  */
1611
1612   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1613     return 0;
1614
1615   pstate->lexptr += namelen;
1616
1617   /* Catch specific keywords.  */
1618
1619   for (const auto &keyword : f_keywords)
1620     if (strlen (keyword.oper) == namelen
1621         && ((!keyword.case_sensitive
1622              && strncasecmp (tokstart, keyword.oper, namelen) == 0)
1623             || (keyword.case_sensitive
1624                 && strncmp (tokstart, keyword.oper, namelen) == 0)))
1625       {
1626         yylval.opcode = keyword.opcode;
1627         return keyword.token;
1628       }
1629
1630   yylval.sval.ptr = tokstart;
1631   yylval.sval.length = namelen;
1632
1633   if (*tokstart == '$')
1634     return DOLLAR_VARIABLE;
1635
1636   /* Use token-type TYPENAME for symbols that happen to be defined
1637      currently as names of types; NAME for other symbols.
1638      The caller is not constrained to care about the distinction.  */
1639   {
1640     std::string tmp = copy_name (yylval.sval);
1641     struct block_symbol result;
1642     const domain_enum lookup_domains[] =
1643     {
1644       STRUCT_DOMAIN,
1645       VAR_DOMAIN,
1646       MODULE_DOMAIN
1647     };
1648     int hextype;
1649
1650     for (const auto &domain : lookup_domains)
1651       {
1652         result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1653                                 domain, NULL);
1654         if (result.symbol && result.symbol->aclass () == LOC_TYPEDEF)
1655           {
1656             yylval.tsym.type = result.symbol->type ();
1657             return TYPENAME;
1658           }
1659
1660         if (result.symbol)
1661           break;
1662       }
1663
1664     yylval.tsym.type
1665       = language_lookup_primitive_type (pstate->language (),
1666                                         pstate->gdbarch (), tmp.c_str ());
1667     if (yylval.tsym.type != NULL)
1668       return TYPENAME;
1669
1670     /* Input names that aren't symbols but ARE valid hex numbers,
1671        when the input radix permits them, can be names or numbers
1672        depending on the parse.  Note we support radixes > 16 here.  */
1673     if (!result.symbol
1674         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1675             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1676       {
1677         YYSTYPE newlval;        /* Its value is ignored.  */
1678         hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1679         if (hextype == INT)
1680           {
1681             yylval.ssym.sym = result;
1682             yylval.ssym.is_a_field_of_this = false;
1683             return NAME_OR_INT;
1684           }
1685       }
1686
1687     if (pstate->parse_completion && *pstate->lexptr == '\0')
1688       saw_name_at_eof = true;
1689
1690     /* Any other kind of symbol */
1691     yylval.ssym.sym = result;
1692     yylval.ssym.is_a_field_of_this = false;
1693     return NAME;
1694   }
1695 }
1696
1697 int
1698 f_language::parser (struct parser_state *par_state) const
1699 {
1700   /* Setting up the parser state.  */
1701   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1702   scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1703                                                         parser_debug);
1704   gdb_assert (par_state != NULL);
1705   pstate = par_state;
1706   last_was_structop = false;
1707   saw_name_at_eof = false;
1708   paren_depth = 0;
1709
1710   struct type_stack stack;
1711   scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1712                                                            &stack);
1713
1714   int result = yyparse ();
1715   if (!result)
1716     pstate->set_operation (pstate->pop ());
1717   return result;
1718 }
1719
1720 static void
1721 yyerror (const char *msg)
1722 {
1723   if (pstate->prev_lexptr)
1724     pstate->lexptr = pstate->prev_lexptr;
1725
1726   error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);
1727 }