gdb/f-exp.y

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