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