gdb/f-exp.y

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