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
 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                         { write_dollar_variable (pstate, $1); }
 513         ;
 514
 515 exp     :       SIZEOF '(' type ')'     %prec UNARY
 516                         { write_exp_elt_opcode (pstate, OP_LONG);
 517                           write_exp_elt_type (pstate,
 518                                               parse_f_type (pstate)
 519                                               ->builtin_integer);
 520                           $3 = check_typedef ($3);
 521                           write_exp_elt_longcst (pstate,
 522                                                  (LONGEST) TYPE_LENGTH ($3));
 523                           write_exp_elt_opcode (pstate, OP_LONG); }
 524         ;
 525
 526 exp     :       BOOLEAN_LITERAL
 527                         { write_exp_elt_opcode (pstate, OP_BOOL);
 528                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 529                           write_exp_elt_opcode (pstate, OP_BOOL);
 530                         }
 531         ;
 532
 533 exp     :       STRING_LITERAL
 534                         {
 535                           write_exp_elt_opcode (pstate, OP_STRING);
 536                           write_exp_string (pstate, $1);
 537                           write_exp_elt_opcode (pstate, OP_STRING);
 538                         }
 539         ;
 540
 541 variable:       name_not_typename
 542                         { struct block_symbol sym = $1.sym;
 543                           std::string name = copy_name ($1.stoken);
 544                           write_exp_symbol_reference (pstate, name.c_str (),
 545                                                       sym);
 546                         }
 547         ;
 548
 549
 550 type    :       ptype
 551         ;
 552
 553 ptype   :       typebase
 554         |       typebase abs_decl
 555                 {
 556                   /* This is where the interesting stuff happens.  */
 557                   int done = 0;
 558                   int array_size;
 559                   struct type *follow_type = $1;
 560                   struct type *range_type;
 561
 562                   while (!done)
 563                     switch (type_stack->pop ())
 564                       {
 565                       case tp_end:
 566                         done = 1;
 567                         break;
 568                       case tp_pointer:
 569                         follow_type = lookup_pointer_type (follow_type);
 570                         break;
 571                       case tp_reference:
 572                         follow_type = lookup_lvalue_reference_type (follow_type);
 573                         break;
 574                       case tp_array:
 575                         array_size = type_stack->pop_int ();
 576                         if (array_size != -1)
 577                           {
 578                             range_type =
 579                               create_static_range_type ((struct type *) NULL,
 580                                                         parse_f_type (pstate)
 581                                                         ->builtin_integer,
 582                                                         0, array_size - 1);
 583                             follow_type =
 584                               create_array_type ((struct type *) NULL,
 585                                                  follow_type, range_type);
 586                           }
 587                         else
 588                           follow_type = lookup_pointer_type (follow_type);
 589                         break;
 590                       case tp_function:
 591                         follow_type = lookup_function_type (follow_type);
 592                         break;
 593                       case tp_kind:
 594                         {
 595                           int kind_val = type_stack->pop_int ();
 596                           follow_type
 597                             = convert_to_kind_type (follow_type, kind_val);
 598                         }
 599                         break;
 600                       }
 601                   $$ = follow_type;
 602                 }
 603         ;
 604
 605 abs_decl:       '*'
 606                         { type_stack->push (tp_pointer); $$ = 0; }
 607         |       '*' abs_decl
 608                         { type_stack->push (tp_pointer); $$ = $2; }
 609         |       '&'
 610                         { type_stack->push (tp_reference); $$ = 0; }
 611         |       '&' abs_decl
 612                         { type_stack->push (tp_reference); $$ = $2; }
 613         |       direct_abs_decl
 614         ;
 615
 616 direct_abs_decl: '(' abs_decl ')'
 617                         { $$ = $2; }
 618         |       '(' KIND '=' INT ')'
 619                         { push_kind_type ($4.val, $4.type); }
 620         |       '*' INT
 621                         { push_kind_type ($2.val, $2.type); }
 622         |       direct_abs_decl func_mod
 623                         { type_stack->push (tp_function); }
 624         |       func_mod
 625                         { type_stack->push (tp_function); }
 626         ;
 627
 628 func_mod:       '(' ')'
 629                         { $$ = 0; }
 630         |       '(' nonempty_typelist ')'
 631                         { free ($2); $$ = 0; }
 632         ;
 633
 634 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 635         :       TYPENAME
 636                         { $$ = $1.type; }
 637         |       INT_KEYWORD
 638                         { $$ = parse_f_type (pstate)->builtin_integer; }
 639         |       INT_S2_KEYWORD
 640                         { $$ = parse_f_type (pstate)->builtin_integer_s2; }
 641         |       CHARACTER
 642                         { $$ = parse_f_type (pstate)->builtin_character; }
 643         |       LOGICAL_S8_KEYWORD
 644                         { $$ = parse_f_type (pstate)->builtin_logical_s8; }
 645         |       LOGICAL_KEYWORD
 646                         { $$ = parse_f_type (pstate)->builtin_logical; }
 647         |       LOGICAL_S2_KEYWORD
 648                         { $$ = parse_f_type (pstate)->builtin_logical_s2; }
 649         |       LOGICAL_S1_KEYWORD
 650                         { $$ = parse_f_type (pstate)->builtin_logical_s1; }
 651         |       REAL_KEYWORD
 652                         { $$ = parse_f_type (pstate)->builtin_real; }
 653         |       REAL_S8_KEYWORD
 654                         { $$ = parse_f_type (pstate)->builtin_real_s8; }
 655         |       REAL_S16_KEYWORD
 656                         { $$ = parse_f_type (pstate)->builtin_real_s16; }
 657         |       COMPLEX_KEYWORD
 658                         { $$ = parse_f_type (pstate)->builtin_complex_s8; }
 659         |       COMPLEX_S8_KEYWORD
 660                         { $$ = parse_f_type (pstate)->builtin_complex_s8; }
 661         |       COMPLEX_S16_KEYWORD
 662                         { $$ = parse_f_type (pstate)->builtin_complex_s16; }
 663         |       COMPLEX_S32_KEYWORD
 664                         { $$ = parse_f_type (pstate)->builtin_complex_s32; }
 665         |       SINGLE PRECISION
 666                         { $$ = parse_f_type (pstate)->builtin_real;}
 667         |       DOUBLE PRECISION
 668                         { $$ = parse_f_type (pstate)->builtin_real_s8;}
 669         |       SINGLE COMPLEX_KEYWORD
 670                         { $$ = parse_f_type (pstate)->builtin_complex_s8;}
 671         |       DOUBLE COMPLEX_KEYWORD
 672                         { $$ = parse_f_type (pstate)->builtin_complex_s16;}
 673         ;
 674
 675 nonempty_typelist
 676         :       type
 677                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 678                   $<ivec>$[0] = 1;      /* Number of types in vector */
 679                   $$[1] = $1;
 680                 }
 681         |       nonempty_typelist ',' type
 682                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 683                   $$ = (struct type **) realloc ((char *) $1, len);
 684                   $$[$<ivec>$[0]] = $3;
 685                 }
 686         ;
 687
 688 name    :       NAME
 689                 {  $$ = $1.stoken; }
 690         ;
 691
 692 name_not_typename :     NAME
 693 /* These would be useful if name_not_typename was useful, but it is just
 694    a fake for "variable", so these cause reduce/reduce conflicts because
 695    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 696    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 697    context where only a name could occur, this might be useful.
 698         |       NAME_OR_INT
 699    */
 700         ;
 701
 702 %%
 703
 704 /* Take care of parsing a number (anything that starts with a digit).
 705    Set yylval and return the token type; update lexptr.
 706    LEN is the number of characters in it.  */
 707
 708 /*** Needs some error checking for the float case ***/
 709
 710 static int
 711 parse_number (struct parser_state *par_state,
 712               const char *p, int len, int parsed_float, YYSTYPE *putithere)
 713 {
 714   LONGEST n = 0;
 715   LONGEST prevn = 0;
 716   int c;
 717   int base = input_radix;
 718   int unsigned_p = 0;
 719   int long_p = 0;
 720   ULONGEST high_bit;
 721   struct type *signed_type;
 722   struct type *unsigned_type;
 723
 724   if (parsed_float)
 725     {
 726       /* It's a float since it contains a point or an exponent.  */
 727       /* [dD] is not understood as an exponent by parse_float,
 728          change it to 'e'.  */
 729       char *tmp, *tmp2;
 730
 731       tmp = xstrdup (p);
 732       for (tmp2 = tmp; *tmp2; ++tmp2)
 733         if (*tmp2 == 'd' || *tmp2 == 'D')
 734           *tmp2 = 'e';
 735
 736       /* FIXME: Should this use different types?  */
 737       putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
 738       bool parsed = parse_float (tmp, len,
 739                                  putithere->typed_val_float.type,
 740                                  putithere->typed_val_float.val);
 741       free (tmp);
 742       return parsed? FLOAT : ERROR;
 743     }
 744
 745   /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
 746   if (p[0] == '0')
 747     switch (p[1])
 748       {
 749       case 'x':
 750       case 'X':
 751         if (len >= 3)
 752           {
 753             p += 2;
 754             base = 16;
 755             len -= 2;
 756           }
 757         break;
 758
 759       case 't':
 760       case 'T':
 761       case 'd':
 762       case 'D':
 763         if (len >= 3)
 764           {
 765             p += 2;
 766             base = 10;
 767             len -= 2;
 768           }
 769         break;
 770
 771       default:
 772         base = 8;
 773         break;
 774       }
 775
 776   while (len-- > 0)
 777     {
 778       c = *p++;
 779       if (isupper (c))
 780         c = tolower (c);
 781       if (len == 0 && c == 'l')
 782         long_p = 1;
 783       else if (len == 0 && c == 'u')
 784         unsigned_p = 1;
 785       else
 786         {
 787           int i;
 788           if (c >= '0' && c <= '9')
 789             i = c - '0';
 790           else if (c >= 'a' && c <= 'f')
 791             i = c - 'a' + 10;
 792           else
 793             return ERROR;       /* Char not a digit */
 794           if (i >= base)
 795             return ERROR;               /* Invalid digit in this base */
 796           n *= base;
 797           n += i;
 798         }
 799       /* Portably test for overflow (only works for nonzero values, so make
 800          a second check for zero).  */
 801       if ((prevn >= n) && n != 0)
 802         unsigned_p=1;           /* Try something unsigned */
 803       /* If range checking enabled, portably test for unsigned overflow.  */
 804       if (RANGE_CHECK && n != 0)
 805         {
 806           if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
 807             range_error (_("Overflow on numeric constant."));
 808         }
 809       prevn = n;
 810     }
 811
 812   /* If the number is too big to be an int, or it's got an l suffix
 813      then it's a long.  Work out if this has to be a long by
 814      shifting right and seeing if anything remains, and the
 815      target int size is different to the target long size.
 816
 817      In the expression below, we could have tested
 818      (n >> gdbarch_int_bit (parse_gdbarch))
 819      to see if it was zero,
 820      but too many compilers warn about that, when ints and longs
 821      are the same size.  So we shift it twice, with fewer bits
 822      each time, for the same result.  */
 823
 824   if ((gdbarch_int_bit (par_state->gdbarch ())
 825        != gdbarch_long_bit (par_state->gdbarch ())
 826        && ((n >> 2)
 827            >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
 828                                                             shift warning */
 829       || long_p)
 830     {
 831       high_bit = ((ULONGEST)1)
 832       << (gdbarch_long_bit (par_state->gdbarch ())-1);
 833       unsigned_type = parse_type (par_state)->builtin_unsigned_long;
 834       signed_type = parse_type (par_state)->builtin_long;
 835     }
 836   else
 837     {
 838       high_bit =
 839         ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
 840       unsigned_type = parse_type (par_state)->builtin_unsigned_int;
 841       signed_type = parse_type (par_state)->builtin_int;
 842     }
 843
 844   putithere->typed_val.val = n;
 845
 846   /* If the high bit of the worked out type is set then this number
 847      has to be unsigned.  */
 848
 849   if (unsigned_p || (n & high_bit))
 850     putithere->typed_val.type = unsigned_type;
 851   else
 852     putithere->typed_val.type = signed_type;
 853
 854   return INT;
 855 }
 856
 857 /* Called to setup the type stack when we encounter a '(kind=N)' type
 858    modifier, performs some bounds checking on 'N' and then pushes this to
 859    the type stack followed by the 'tp_kind' marker.  */
 860 static void
 861 push_kind_type (LONGEST val, struct type *type)
 862 {
 863   int ival;
 864
 865   if (type->is_unsigned ())
 866     {
 867       ULONGEST uval = static_cast <ULONGEST> (val);
 868       if (uval > INT_MAX)
 869         error (_("kind value out of range"));
 870       ival = static_cast <int> (uval);
 871     }
 872   else
 873     {
 874       if (val > INT_MAX || val < 0)
 875         error (_("kind value out of range"));
 876       ival = static_cast <int> (val);
 877     }
 878
 879   type_stack->push (ival);
 880   type_stack->push (tp_kind);
 881 }
 882
 883 /* Called when a type has a '(kind=N)' modifier after it, for example
 884    'character(kind=1)'.  The BASETYPE is the type described by 'character'
 885    in our example, and KIND is the integer '1'.  This function returns a
 886    new type that represents the basetype of a specific kind.  */
 887 static struct type *
 888 convert_to_kind_type (struct type *basetype, int kind)
 889 {
 890   if (basetype == parse_f_type (pstate)->builtin_character)
 891     {
 892       /* Character of kind 1 is a special case, this is the same as the
 893          base character type.  */
 894       if (kind == 1)
 895         return parse_f_type (pstate)->builtin_character;
 896     }
 897   else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
 898     {
 899       if (kind == 4)
 900         return parse_f_type (pstate)->builtin_complex_s8;
 901       else if (kind == 8)
 902         return parse_f_type (pstate)->builtin_complex_s16;
 903       else if (kind == 16)
 904         return parse_f_type (pstate)->builtin_complex_s32;
 905     }
 906   else if (basetype == parse_f_type (pstate)->builtin_real)
 907     {
 908       if (kind == 4)
 909         return parse_f_type (pstate)->builtin_real;
 910       else if (kind == 8)
 911         return parse_f_type (pstate)->builtin_real_s8;
 912       else if (kind == 16)
 913         return parse_f_type (pstate)->builtin_real_s16;
 914     }
 915   else if (basetype == parse_f_type (pstate)->builtin_logical)
 916     {
 917       if (kind == 1)
 918         return parse_f_type (pstate)->builtin_logical_s1;
 919       else if (kind == 2)
 920         return parse_f_type (pstate)->builtin_logical_s2;
 921       else if (kind == 4)
 922         return parse_f_type (pstate)->builtin_logical;
 923       else if (kind == 8)
 924         return parse_f_type (pstate)->builtin_logical_s8;
 925     }
 926   else if (basetype == parse_f_type (pstate)->builtin_integer)
 927     {
 928       if (kind == 2)
 929         return parse_f_type (pstate)->builtin_integer_s2;
 930       else if (kind == 4)
 931         return parse_f_type (pstate)->builtin_integer;
 932       else if (kind == 8)
 933         return parse_f_type (pstate)->builtin_integer_s8;
 934     }
 935
 936   error (_("unsupported kind %d for type %s"),
 937          kind, TYPE_SAFE_NAME (basetype));
 938
 939   /* Should never get here.  */
 940   return nullptr;
 941 }
 942
 943 struct token
 944 {
 945   /* The string to match against.  */
 946   const char *oper;
 947
 948   /* The lexer token to return.  */
 949   int token;
 950
 951   /* The expression opcode to embed within the token.  */
 952   enum exp_opcode opcode;
 953
 954   /* When this is true the string in OPER is matched exactly including
 955      case, when this is false OPER is matched case insensitively.  */
 956   bool case_sensitive;
 957 };
 958
 959 /* List of Fortran operators.  */
 960
 961 static const struct token fortran_operators[] =
 962 {
 963   { ".and.", BOOL_AND, BINOP_END, false },
 964   { ".or.", BOOL_OR, BINOP_END, false },
 965   { ".not.", BOOL_NOT, BINOP_END, false },
 966   { ".eq.", EQUAL, BINOP_END, false },
 967   { ".eqv.", EQUAL, BINOP_END, false },
 968   { ".neqv.", NOTEQUAL, BINOP_END, false },
 969   { "==", EQUAL, BINOP_END, false },
 970   { ".ne.", NOTEQUAL, BINOP_END, false },
 971   { "/=", NOTEQUAL, BINOP_END, false },
 972   { ".le.", LEQ, BINOP_END, false },
 973   { "<=", LEQ, BINOP_END, false },
 974   { ".ge.", GEQ, BINOP_END, false },
 975   { ">=", GEQ, BINOP_END, false },
 976   { ".gt.", GREATERTHAN, BINOP_END, false },
 977   { ">", GREATERTHAN, BINOP_END, false },
 978   { ".lt.", LESSTHAN, BINOP_END, false },
 979   { "<", LESSTHAN, BINOP_END, false },
 980   { "**", STARSTAR, BINOP_EXP, false },
 981 };
 982
 983 /* Holds the Fortran representation of a boolean, and the integer value we
 984    substitute in when one of the matching strings is parsed.  */
 985 struct f77_boolean_val
 986 {
 987   /* The string representing a Fortran boolean.  */
 988   const char *name;
 989
 990   /* The integer value to replace it with.  */
 991   int value;
 992 };
 993
 994 /* The set of Fortran booleans.  These are matched case insensitively.  */
 995 static const struct f77_boolean_val boolean_values[]  =
 996 {
 997   { ".true.", 1 },
 998   { ".false.", 0 }
 999 };
1000
1001 static const struct token f77_keywords[] =
1002 {
1003   /* Historically these have always been lowercase only in GDB.  */
1004   { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END, true },
1005   { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END, true },
1006   { "character", CHARACTER, BINOP_END, true },
1007   { "integer_2", INT_S2_KEYWORD, BINOP_END, true },
1008   { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END, true },
1009   { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END, true },
1010   { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END, true },
1011   { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END, true },
1012   { "integer", INT_KEYWORD, BINOP_END, true },
1013   { "logical", LOGICAL_KEYWORD, BINOP_END, true },
1014   { "real_16", REAL_S16_KEYWORD, BINOP_END, true },
1015   { "complex", COMPLEX_KEYWORD, BINOP_END, true },
1016   { "sizeof", SIZEOF, BINOP_END, true },
1017   { "real_8", REAL_S8_KEYWORD, BINOP_END, true },
1018   { "real", REAL_KEYWORD, BINOP_END, true },
1019   { "single", SINGLE, BINOP_END, true },
1020   { "double", DOUBLE, BINOP_END, true },
1021   { "precision", PRECISION, BINOP_END, true },
1022   /* The following correspond to actual functions in Fortran and are case
1023      insensitive.  */
1024   { "kind", KIND, BINOP_END, false },
1025   { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1026   { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1027   { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1028   { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1029   { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1030   { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1031 };
1032
1033 /* Implementation of a dynamically expandable buffer for processing input
1034    characters acquired through lexptr and building a value to return in
1035    yylval.  Ripped off from ch-exp.y */
1036
1037 static char *tempbuf;           /* Current buffer contents */
1038 static int tempbufsize;         /* Size of allocated buffer */
1039 static int tempbufindex;        /* Current index into buffer */
1040
1041 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
1042
1043 #define CHECKBUF(size) \
1044   do { \
1045     if (tempbufindex + (size) >= tempbufsize) \
1046       { \
1047         growbuf_by_size (size); \
1048       } \
1049   } while (0);
1050
1051
1052 /* Grow the static temp buffer if necessary, including allocating the
1053    first one on demand.  */
1054
1055 static void
1056 growbuf_by_size (int count)
1057 {
1058   int growby;
1059
1060   growby = std::max (count, GROWBY_MIN_SIZE);
1061   tempbufsize += growby;
1062   if (tempbuf == NULL)
1063     tempbuf = (char *) malloc (tempbufsize);
1064   else
1065     tempbuf = (char *) realloc (tempbuf, tempbufsize);
1066 }
1067
1068 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1069    string-literals.
1070
1071    Recognize a string literal.  A string literal is a nonzero sequence
1072    of characters enclosed in matching single quotes, except that
1073    a single character inside single quotes is a character literal, which
1074    we reject as a string literal.  To embed the terminator character inside
1075    a string, it is simply doubled (I.E. 'this''is''one''string') */
1076
1077 static int
1078 match_string_literal (void)
1079 {
1080   const char *tokptr = pstate->lexptr;
1081
1082   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1083     {
1084       CHECKBUF (1);
1085       if (*tokptr == *pstate->lexptr)
1086         {
1087           if (*(tokptr + 1) == *pstate->lexptr)
1088             tokptr++;
1089           else
1090             break;
1091         }
1092       tempbuf[tempbufindex++] = *tokptr;
1093     }
1094   if (*tokptr == '\0'                                   /* no terminator */
1095       || tempbufindex == 0)                             /* no string */
1096     return 0;
1097   else
1098     {
1099       tempbuf[tempbufindex] = '\0';
1100       yylval.sval.ptr = tempbuf;
1101       yylval.sval.length = tempbufindex;
1102       pstate->lexptr = ++tokptr;
1103       return STRING_LITERAL;
1104     }
1105 }
1106
1107 /* This is set if a NAME token appeared at the very end of the input
1108    string, with no whitespace separating the name from the EOF.  This
1109    is used only when parsing to do field name completion.  */
1110 static bool saw_name_at_eof;
1111
1112 /* This is set if the previously-returned token was a structure
1113    operator '%'.  */
1114 static bool last_was_structop;
1115
1116 /* Read one token, getting characters through lexptr.  */
1117
1118 static int
1119 yylex (void)
1120 {
1121   int c;
1122   int namelen;
1123   unsigned int token;
1124   const char *tokstart;
1125   bool saw_structop = last_was_structop;
1126
1127   last_was_structop = false;
1128
1129  retry:
1130
1131   pstate->prev_lexptr = pstate->lexptr;
1132
1133   tokstart = pstate->lexptr;
1134
1135   /* First of all, let us make sure we are not dealing with the
1136      special tokens .true. and .false. which evaluate to 1 and 0.  */
1137
1138   if (*pstate->lexptr == '.')
1139     {
1140       for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1141         {
1142           if (strncasecmp (tokstart, boolean_values[i].name,
1143                            strlen (boolean_values[i].name)) == 0)
1144             {
1145               pstate->lexptr += strlen (boolean_values[i].name);
1146               yylval.lval = boolean_values[i].value;
1147               return BOOLEAN_LITERAL;
1148             }
1149         }
1150     }
1151
1152   /* See if it is a Fortran operator.  */
1153   for (int i = 0; i < ARRAY_SIZE (fortran_operators); i++)
1154     if (strncasecmp (tokstart, fortran_operators[i].oper,
1155                      strlen (fortran_operators[i].oper)) == 0)
1156       {
1157         gdb_assert (!fortran_operators[i].case_sensitive);
1158         pstate->lexptr += strlen (fortran_operators[i].oper);
1159         yylval.opcode = fortran_operators[i].opcode;
1160         return fortran_operators[i].token;
1161       }
1162
1163   switch (c = *tokstart)
1164     {
1165     case 0:
1166       if (saw_name_at_eof)
1167         {
1168           saw_name_at_eof = false;
1169           return COMPLETE;
1170         }
1171       else if (pstate->parse_completion && saw_structop)
1172         return COMPLETE;
1173       return 0;
1174
1175     case ' ':
1176     case '\t':
1177     case '\n':
1178       pstate->lexptr++;
1179       goto retry;
1180
1181     case '\'':
1182       token = match_string_literal ();
1183       if (token != 0)
1184         return (token);
1185       break;
1186
1187     case '(':
1188       paren_depth++;
1189       pstate->lexptr++;
1190       return c;
1191
1192     case ')':
1193       if (paren_depth == 0)
1194         return 0;
1195       paren_depth--;
1196       pstate->lexptr++;
1197       return c;
1198
1199     case ',':
1200       if (pstate->comma_terminates && paren_depth == 0)
1201         return 0;
1202       pstate->lexptr++;
1203       return c;
1204
1205     case '.':
1206       /* Might be a floating point number.  */
1207       if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1208         goto symbol;            /* Nope, must be a symbol.  */
1209       /* FALL THRU.  */
1210
1211     case '0':
1212     case '1':
1213     case '2':
1214     case '3':
1215     case '4':
1216     case '5':
1217     case '6':
1218     case '7':
1219     case '8':
1220     case '9':
1221       {
1222         /* It's a number.  */
1223         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1224         const char *p = tokstart;
1225         int hex = input_radix > 10;
1226
1227         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1228           {
1229             p += 2;
1230             hex = 1;
1231           }
1232         else if (c == '0' && (p[1]=='t' || p[1]=='T'
1233                               || p[1]=='d' || p[1]=='D'))
1234           {
1235             p += 2;
1236             hex = 0;
1237           }
1238
1239         for (;; ++p)
1240           {
1241             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1242               got_dot = got_e = 1;
1243             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1244               got_dot = got_d = 1;
1245             else if (!hex && !got_dot && *p == '.')
1246               got_dot = 1;
1247             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1248                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1249                      && (*p == '-' || *p == '+'))
1250               /* This is the sign of the exponent, not the end of the
1251                  number.  */
1252               continue;
1253             /* We will take any letters or digits.  parse_number will
1254                complain if past the radix, or if L or U are not final.  */
1255             else if ((*p < '0' || *p > '9')
1256                      && ((*p < 'a' || *p > 'z')
1257                          && (*p < 'A' || *p > 'Z')))
1258               break;
1259           }
1260         toktype = parse_number (pstate, tokstart, p - tokstart,
1261                                 got_dot|got_e|got_d,
1262                                 &yylval);
1263         if (toktype == ERROR)
1264           {
1265             char *err_copy = (char *) alloca (p - tokstart + 1);
1266
1267             memcpy (err_copy, tokstart, p - tokstart);
1268             err_copy[p - tokstart] = 0;
1269             error (_("Invalid number \"%s\"."), err_copy);
1270           }
1271         pstate->lexptr = p;
1272         return toktype;
1273       }
1274
1275     case '%':
1276       last_was_structop = true;
1277       /* Fall through.  */
1278     case '+':
1279     case '-':
1280     case '*':
1281     case '/':
1282     case '|':
1283     case '&':
1284     case '^':
1285     case '~':
1286     case '!':
1287     case '@':
1288     case '<':
1289     case '>':
1290     case '[':
1291     case ']':
1292     case '?':
1293     case ':':
1294     case '=':
1295     case '{':
1296     case '}':
1297     symbol:
1298       pstate->lexptr++;
1299       return c;
1300     }
1301
1302   if (!(c == '_' || c == '$' || c ==':'
1303         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1304     /* We must have come across a bad character (e.g. ';').  */
1305     error (_("Invalid character '%c' in expression."), c);
1306
1307   namelen = 0;
1308   for (c = tokstart[namelen];
1309        (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1310         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1311        c = tokstart[++namelen]);
1312
1313   /* The token "if" terminates the expression and is NOT
1314      removed from the input stream.  */
1315
1316   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1317     return 0;
1318
1319   pstate->lexptr += namelen;
1320
1321   /* Catch specific keywords.  */
1322
1323   for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1324     if (strlen (f77_keywords[i].oper) == namelen
1325         && ((!f77_keywords[i].case_sensitive
1326              && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1327             || (f77_keywords[i].case_sensitive
1328                 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1329       {
1330         yylval.opcode = f77_keywords[i].opcode;
1331         return f77_keywords[i].token;
1332       }
1333
1334   yylval.sval.ptr = tokstart;
1335   yylval.sval.length = namelen;
1336
1337   if (*tokstart == '$')
1338     return DOLLAR_VARIABLE;
1339
1340   /* Use token-type TYPENAME for symbols that happen to be defined
1341      currently as names of types; NAME for other symbols.
1342      The caller is not constrained to care about the distinction.  */
1343   {
1344     std::string tmp = copy_name (yylval.sval);
1345     struct block_symbol result;
1346     enum domain_enum_tag lookup_domains[] =
1347     {
1348       STRUCT_DOMAIN,
1349       VAR_DOMAIN,
1350       MODULE_DOMAIN
1351     };
1352     int hextype;
1353
1354     for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1355       {
1356         result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1357                                 lookup_domains[i], NULL);
1358         if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1359           {
1360             yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1361             return TYPENAME;
1362           }
1363
1364         if (result.symbol)
1365           break;
1366       }
1367
1368     yylval.tsym.type
1369       = language_lookup_primitive_type (pstate->language (),
1370                                         pstate->gdbarch (), tmp.c_str ());
1371     if (yylval.tsym.type != NULL)
1372       return TYPENAME;
1373
1374     /* Input names that aren't symbols but ARE valid hex numbers,
1375        when the input radix permits them, can be names or numbers
1376        depending on the parse.  Note we support radixes > 16 here.  */
1377     if (!result.symbol
1378         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1379             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1380       {
1381         YYSTYPE newlval;        /* Its value is ignored.  */
1382         hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1383         if (hextype == INT)
1384           {
1385             yylval.ssym.sym = result;
1386             yylval.ssym.is_a_field_of_this = false;
1387             return NAME_OR_INT;
1388           }
1389       }
1390
1391     if (pstate->parse_completion && *pstate->lexptr == '\0')
1392       saw_name_at_eof = true;
1393
1394     /* Any other kind of symbol */
1395     yylval.ssym.sym = result;
1396     yylval.ssym.is_a_field_of_this = false;
1397     return NAME;
1398   }
1399 }
1400
1401 int
1402 f_language::parser (struct parser_state *par_state) const
1403 {
1404   /* Setting up the parser state.  */
1405   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1406   scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1407                                                         parser_debug);
1408   gdb_assert (par_state != NULL);
1409   pstate = par_state;
1410   last_was_structop = false;
1411   saw_name_at_eof = false;
1412   paren_depth = 0;
1413
1414   struct type_stack stack;
1415   scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1416                                                            &stack);
1417
1418   return yyparse ();
1419 }
1420
1421 static void
1422 yyerror (const char *msg)
1423 {
1424   if (pstate->prev_lexptr)
1425     pstate->lexptr = pstate->prev_lexptr;
1426
1427   error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);
1428 }