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   { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1050 };
1051
1052 /* Implementation of a dynamically expandable buffer for processing input
1053    characters acquired through lexptr and building a value to return in
1054    yylval.  Ripped off from ch-exp.y */
1055
1056 static char *tempbuf;           /* Current buffer contents */
1057 static int tempbufsize;         /* Size of allocated buffer */
1058 static int tempbufindex;        /* Current index into buffer */
1059
1060 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
1061
1062 #define CHECKBUF(size) \
1063   do { \
1064     if (tempbufindex + (size) >= tempbufsize) \
1065       { \
1066         growbuf_by_size (size); \
1067       } \
1068   } while (0);
1069
1070
1071 /* Grow the static temp buffer if necessary, including allocating the
1072    first one on demand.  */
1073
1074 static void
1075 growbuf_by_size (int count)
1076 {
1077   int growby;
1078
1079   growby = std::max (count, GROWBY_MIN_SIZE);
1080   tempbufsize += growby;
1081   if (tempbuf == NULL)
1082     tempbuf = (char *) malloc (tempbufsize);
1083   else
1084     tempbuf = (char *) realloc (tempbuf, tempbufsize);
1085 }
1086
1087 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1088    string-literals.
1089
1090    Recognize a string literal.  A string literal is a nonzero sequence
1091    of characters enclosed in matching single quotes, except that
1092    a single character inside single quotes is a character literal, which
1093    we reject as a string literal.  To embed the terminator character inside
1094    a string, it is simply doubled (I.E. 'this''is''one''string') */
1095
1096 static int
1097 match_string_literal (void)
1098 {
1099   const char *tokptr = pstate->lexptr;
1100
1101   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1102     {
1103       CHECKBUF (1);
1104       if (*tokptr == *pstate->lexptr)
1105         {
1106           if (*(tokptr + 1) == *pstate->lexptr)
1107             tokptr++;
1108           else
1109             break;
1110         }
1111       tempbuf[tempbufindex++] = *tokptr;
1112     }
1113   if (*tokptr == '\0'                                   /* no terminator */
1114       || tempbufindex == 0)                             /* no string */
1115     return 0;
1116   else
1117     {
1118       tempbuf[tempbufindex] = '\0';
1119       yylval.sval.ptr = tempbuf;
1120       yylval.sval.length = tempbufindex;
1121       pstate->lexptr = ++tokptr;
1122       return STRING_LITERAL;
1123     }
1124 }
1125
1126 /* This is set if a NAME token appeared at the very end of the input
1127    string, with no whitespace separating the name from the EOF.  This
1128    is used only when parsing to do field name completion.  */
1129 static bool saw_name_at_eof;
1130
1131 /* This is set if the previously-returned token was a structure
1132    operator '%'.  */
1133 static bool last_was_structop;
1134
1135 /* Read one token, getting characters through lexptr.  */
1136
1137 static int
1138 yylex (void)
1139 {
1140   int c;
1141   int namelen;
1142   unsigned int token;
1143   const char *tokstart;
1144   bool saw_structop = last_was_structop;
1145
1146   last_was_structop = false;
1147
1148  retry:
1149
1150   pstate->prev_lexptr = pstate->lexptr;
1151
1152   tokstart = pstate->lexptr;
1153
1154   /* First of all, let us make sure we are not dealing with the
1155      special tokens .true. and .false. which evaluate to 1 and 0.  */
1156
1157   if (*pstate->lexptr == '.')
1158     {
1159       for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1160         {
1161           if (strncasecmp (tokstart, boolean_values[i].name,
1162                            strlen (boolean_values[i].name)) == 0)
1163             {
1164               pstate->lexptr += strlen (boolean_values[i].name);
1165               yylval.lval = boolean_values[i].value;
1166               return BOOLEAN_LITERAL;
1167             }
1168         }
1169     }
1170
1171   /* See if it is a Fortran operator.  */
1172   for (int i = 0; i < ARRAY_SIZE (fortran_operators); i++)
1173     if (strncasecmp (tokstart, fortran_operators[i].oper,
1174                      strlen (fortran_operators[i].oper)) == 0)
1175       {
1176         gdb_assert (!fortran_operators[i].case_sensitive);
1177         pstate->lexptr += strlen (fortran_operators[i].oper);
1178         yylval.opcode = fortran_operators[i].opcode;
1179         return fortran_operators[i].token;
1180       }
1181
1182   switch (c = *tokstart)
1183     {
1184     case 0:
1185       if (saw_name_at_eof)
1186         {
1187           saw_name_at_eof = false;
1188           return COMPLETE;
1189         }
1190       else if (pstate->parse_completion && saw_structop)
1191         return COMPLETE;
1192       return 0;
1193
1194     case ' ':
1195     case '\t':
1196     case '\n':
1197       pstate->lexptr++;
1198       goto retry;
1199
1200     case '\'':
1201       token = match_string_literal ();
1202       if (token != 0)
1203         return (token);
1204       break;
1205
1206     case '(':
1207       paren_depth++;
1208       pstate->lexptr++;
1209       return c;
1210
1211     case ')':
1212       if (paren_depth == 0)
1213         return 0;
1214       paren_depth--;
1215       pstate->lexptr++;
1216       return c;
1217
1218     case ',':
1219       if (pstate->comma_terminates && paren_depth == 0)
1220         return 0;
1221       pstate->lexptr++;
1222       return c;
1223
1224     case '.':
1225       /* Might be a floating point number.  */
1226       if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1227         goto symbol;            /* Nope, must be a symbol.  */
1228       /* FALL THRU.  */
1229
1230     case '0':
1231     case '1':
1232     case '2':
1233     case '3':
1234     case '4':
1235     case '5':
1236     case '6':
1237     case '7':
1238     case '8':
1239     case '9':
1240       {
1241         /* It's a number.  */
1242         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1243         const char *p = tokstart;
1244         int hex = input_radix > 10;
1245
1246         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1247           {
1248             p += 2;
1249             hex = 1;
1250           }
1251         else if (c == '0' && (p[1]=='t' || p[1]=='T'
1252                               || p[1]=='d' || p[1]=='D'))
1253           {
1254             p += 2;
1255             hex = 0;
1256           }
1257
1258         for (;; ++p)
1259           {
1260             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1261               got_dot = got_e = 1;
1262             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1263               got_dot = got_d = 1;
1264             else if (!hex && !got_dot && *p == '.')
1265               got_dot = 1;
1266             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1267                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1268                      && (*p == '-' || *p == '+'))
1269               /* This is the sign of the exponent, not the end of the
1270                  number.  */
1271               continue;
1272             /* We will take any letters or digits.  parse_number will
1273                complain if past the radix, or if L or U are not final.  */
1274             else if ((*p < '0' || *p > '9')
1275                      && ((*p < 'a' || *p > 'z')
1276                          && (*p < 'A' || *p > 'Z')))
1277               break;
1278           }
1279         toktype = parse_number (pstate, tokstart, p - tokstart,
1280                                 got_dot|got_e|got_d,
1281                                 &yylval);
1282         if (toktype == ERROR)
1283           {
1284             char *err_copy = (char *) alloca (p - tokstart + 1);
1285
1286             memcpy (err_copy, tokstart, p - tokstart);
1287             err_copy[p - tokstart] = 0;
1288             error (_("Invalid number \"%s\"."), err_copy);
1289           }
1290         pstate->lexptr = p;
1291         return toktype;
1292       }
1293
1294     case '%':
1295       last_was_structop = true;
1296       /* Fall through.  */
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     case '}':
1316     symbol:
1317       pstate->lexptr++;
1318       return c;
1319     }
1320
1321   if (!(c == '_' || c == '$' || c ==':'
1322         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1323     /* We must have come across a bad character (e.g. ';').  */
1324     error (_("Invalid character '%c' in expression."), c);
1325
1326   namelen = 0;
1327   for (c = tokstart[namelen];
1328        (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1329         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1330        c = tokstart[++namelen]);
1331
1332   /* The token "if" terminates the expression and is NOT
1333      removed from the input stream.  */
1334
1335   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1336     return 0;
1337
1338   pstate->lexptr += namelen;
1339
1340   /* Catch specific keywords.  */
1341
1342   for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1343     if (strlen (f77_keywords[i].oper) == namelen
1344         && ((!f77_keywords[i].case_sensitive
1345              && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1346             || (f77_keywords[i].case_sensitive
1347                 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1348       {
1349         yylval.opcode = f77_keywords[i].opcode;
1350         return f77_keywords[i].token;
1351       }
1352
1353   yylval.sval.ptr = tokstart;
1354   yylval.sval.length = namelen;
1355
1356   if (*tokstart == '$')
1357     return DOLLAR_VARIABLE;
1358
1359   /* Use token-type TYPENAME for symbols that happen to be defined
1360      currently as names of types; NAME for other symbols.
1361      The caller is not constrained to care about the distinction.  */
1362   {
1363     std::string tmp = copy_name (yylval.sval);
1364     struct block_symbol result;
1365     enum domain_enum_tag lookup_domains[] =
1366     {
1367       STRUCT_DOMAIN,
1368       VAR_DOMAIN,
1369       MODULE_DOMAIN
1370     };
1371     int hextype;
1372
1373     for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1374       {
1375         result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1376                                 lookup_domains[i], NULL);
1377         if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1378           {
1379             yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1380             return TYPENAME;
1381           }
1382
1383         if (result.symbol)
1384           break;
1385       }
1386
1387     yylval.tsym.type
1388       = language_lookup_primitive_type (pstate->language (),
1389                                         pstate->gdbarch (), tmp.c_str ());
1390     if (yylval.tsym.type != NULL)
1391       return TYPENAME;
1392
1393     /* Input names that aren't symbols but ARE valid hex numbers,
1394        when the input radix permits them, can be names or numbers
1395        depending on the parse.  Note we support radixes > 16 here.  */
1396     if (!result.symbol
1397         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1398             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1399       {
1400         YYSTYPE newlval;        /* Its value is ignored.  */
1401         hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1402         if (hextype == INT)
1403           {
1404             yylval.ssym.sym = result;
1405             yylval.ssym.is_a_field_of_this = false;
1406             return NAME_OR_INT;
1407           }
1408       }
1409
1410     if (pstate->parse_completion && *pstate->lexptr == '\0')
1411       saw_name_at_eof = true;
1412
1413     /* Any other kind of symbol */
1414     yylval.ssym.sym = result;
1415     yylval.ssym.is_a_field_of_this = false;
1416     return NAME;
1417   }
1418 }
1419
1420 int
1421 f_language::parser (struct parser_state *par_state) const
1422 {
1423   /* Setting up the parser state.  */
1424   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1425   scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1426                                                         parser_debug);
1427   gdb_assert (par_state != NULL);
1428   pstate = par_state;
1429   last_was_structop = false;
1430   saw_name_at_eof = false;
1431   paren_depth = 0;
1432
1433   struct type_stack stack;
1434   scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1435                                                            &stack);
1436
1437   return yyparse ();
1438 }
1439
1440 static void
1441 yyerror (const char *msg)
1442 {
1443   if (pstate->prev_lexptr)
1444     pstate->lexptr = pstate->prev_lexptr;
1445
1446   error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);
1447 }