gdb/f-exp.y

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