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