gdb/f-exp.y

   1
   2 /* YACC parser for Fortran expressions, for GDB.
   3    Copyright (C) 1986-2018 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
  58 #define parse_type(ps) builtin_type (parse_gdbarch (ps))
  59 #define parse_f_type(ps) builtin_f_type (parse_gdbarch (ps))
  60
  61 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
  62    etc).  */
  63 #define GDB_YY_REMAP_PREFIX f_
  64 #include "yy-remap.h"
  65
  66 /* The state of the parser, used internally when we are parsing the
  67    expression.  */
  68
  69 static struct parser_state *pstate = NULL;
  70
  71 int yyparse (void);
  72
  73 static int yylex (void);
  74
  75 static void yyerror (const char *);
  76
  77 static void growbuf_by_size (int);
  78
  79 static int match_string_literal (void);
  80
  81 %}
  82
  83 /* Although the yacc "value" of an expression is not used,
  84    since the result is stored in the structure being created,
  85    other node types do have values.  */
  86
  87 %union
  88   {
  89     LONGEST lval;
  90     struct {
  91       LONGEST val;
  92       struct type *type;
  93     } typed_val;
  94     struct {
  95       gdb_byte val[16];
  96       struct type *type;
  97     } typed_val_float;
  98     struct symbol *sym;
  99     struct type *tval;
 100     struct stoken sval;
 101     struct ttype tsym;
 102     struct symtoken ssym;
 103     int voidval;
 104     struct block *bval;
 105     enum exp_opcode opcode;
 106     struct internalvar *ivar;
 107
 108     struct type **tvec;
 109     int *ivec;
 110   }
 111
 112 %{
 113 /* YYSTYPE gets defined by %union */
 114 static int parse_number (struct parser_state *, const char *, int,
 115                          int, YYSTYPE *);
 116 %}
 117
 118 %type <voidval> exp  type_exp start variable
 119 %type <tval> type typebase
 120 %type <tvec> nonempty_typelist
 121 /* %type <bval> block */
 122
 123 /* Fancy type parsing.  */
 124 %type <voidval> func_mod direct_abs_decl abs_decl
 125 %type <tval> ptype
 126
 127 %token <typed_val> INT
 128 %token <typed_val_float> FLOAT
 129
 130 /* Both NAME and TYPENAME tokens represent symbols in the input,
 131    and both convey their data as strings.
 132    But a TYPENAME is a string that happens to be defined as a typedef
 133    or builtin type name (such as int or char)
 134    and a NAME is any other symbol.
 135    Contexts where this distinction is not important can use the
 136    nonterminal "name", which matches either NAME or TYPENAME.  */
 137
 138 %token <sval> STRING_LITERAL
 139 %token <lval> BOOLEAN_LITERAL
 140 %token <ssym> NAME
 141 %token <tsym> TYPENAME
 142 %type <sval> name
 143 %type <ssym> name_not_typename
 144
 145 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
 146    but which would parse as a valid number in the current input radix.
 147    E.g. "c" when input_radix==16.  Depending on the parse, it will be
 148    turned into a name or into a number.  */
 149
 150 %token <ssym> NAME_OR_INT
 151
 152 %token  SIZEOF
 153 %token ERROR
 154
 155 /* Special type cases, put in to allow the parser to distinguish different
 156    legal basetypes.  */
 157 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
 158 %token LOGICAL_S8_KEYWORD
 159 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
 160 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
 161 %token BOOL_AND BOOL_OR BOOL_NOT
 162 %token <lval> CHARACTER
 163
 164 %token <voidval> VARIABLE
 165
 166 %token <opcode> ASSIGN_MODIFY
 167
 168 %left ','
 169 %left ABOVE_COMMA
 170 %right '=' ASSIGN_MODIFY
 171 %right '?'
 172 %left BOOL_OR
 173 %right BOOL_NOT
 174 %left BOOL_AND
 175 %left '|'
 176 %left '^'
 177 %left '&'
 178 %left EQUAL NOTEQUAL
 179 %left LESSTHAN GREATERTHAN LEQ GEQ
 180 %left LSH RSH
 181 %left '@'
 182 %left '+' '-'
 183 %left '*' '/'
 184 %right STARSTAR
 185 %right '%'
 186 %right UNARY
 187 %right '('
 188
 189 \f
 190 %%
 191
 192 start   :       exp
 193         |       type_exp
 194         ;
 195
 196 type_exp:       type
 197                         { write_exp_elt_opcode (pstate, OP_TYPE);
 198                           write_exp_elt_type (pstate, $1);
 199                           write_exp_elt_opcode (pstate, OP_TYPE); }
 200         ;
 201
 202 exp     :       '(' exp ')'
 203                         { }
 204         ;
 205
 206 /* Expressions, not including the comma operator.  */
 207 exp     :       '*' exp    %prec UNARY
 208                         { write_exp_elt_opcode (pstate, UNOP_IND); }
 209         ;
 210
 211 exp     :       '&' exp    %prec UNARY
 212                         { write_exp_elt_opcode (pstate, UNOP_ADDR); }
 213         ;
 214
 215 exp     :       '-' exp    %prec UNARY
 216                         { write_exp_elt_opcode (pstate, UNOP_NEG); }
 217         ;
 218
 219 exp     :       BOOL_NOT exp    %prec UNARY
 220                         { write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
 221         ;
 222
 223 exp     :       '~' exp    %prec UNARY
 224                         { write_exp_elt_opcode (pstate, UNOP_COMPLEMENT); }
 225         ;
 226
 227 exp     :       SIZEOF exp       %prec UNARY
 228                         { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
 229         ;
 230
 231 /* No more explicit array operators, we treat everything in F77 as
 232    a function call.  The disambiguation as to whether we are
 233    doing a subscript operation or a function call is done
 234    later in eval.c.  */
 235
 236 exp     :       exp '('
 237                         { start_arglist (); }
 238                 arglist ')'
 239                         { write_exp_elt_opcode (pstate,
 240                                                 OP_F77_UNDETERMINED_ARGLIST);
 241                           write_exp_elt_longcst (pstate,
 242                                                  (LONGEST) end_arglist ());
 243                           write_exp_elt_opcode (pstate,
 244                                               OP_F77_UNDETERMINED_ARGLIST); }
 245         ;
 246
 247 arglist :
 248         ;
 249
 250 arglist :       exp
 251                         { arglist_len = 1; }
 252         ;
 253
 254 arglist :       subrange
 255                         { arglist_len = 1; }
 256         ;
 257
 258 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 259                         { arglist_len++; }
 260         ;
 261
 262 /* There are four sorts of subrange types in F90.  */
 263
 264 subrange:       exp ':' exp     %prec ABOVE_COMMA
 265                         { write_exp_elt_opcode (pstate, OP_RANGE);
 266                           write_exp_elt_longcst (pstate, NONE_BOUND_DEFAULT);
 267                           write_exp_elt_opcode (pstate, OP_RANGE); }
 268         ;
 269
 270 subrange:       exp ':' %prec ABOVE_COMMA
 271                         { write_exp_elt_opcode (pstate, OP_RANGE);
 272                           write_exp_elt_longcst (pstate, HIGH_BOUND_DEFAULT);
 273                           write_exp_elt_opcode (pstate, OP_RANGE); }
 274         ;
 275
 276 subrange:       ':' exp %prec ABOVE_COMMA
 277                         { write_exp_elt_opcode (pstate, OP_RANGE);
 278                           write_exp_elt_longcst (pstate, LOW_BOUND_DEFAULT);
 279                           write_exp_elt_opcode (pstate, OP_RANGE); }
 280         ;
 281
 282 subrange:       ':'     %prec ABOVE_COMMA
 283                         { write_exp_elt_opcode (pstate, OP_RANGE);
 284                           write_exp_elt_longcst (pstate, BOTH_BOUND_DEFAULT);
 285                           write_exp_elt_opcode (pstate, OP_RANGE); }
 286         ;
 287
 288 complexnum:     exp ',' exp
 289                         { }
 290         ;
 291
 292 exp     :       '(' complexnum ')'
 293                         { write_exp_elt_opcode (pstate, OP_COMPLEX);
 294                           write_exp_elt_type (pstate,
 295                                               parse_f_type (pstate)
 296                                               ->builtin_complex_s16);
 297                           write_exp_elt_opcode (pstate, OP_COMPLEX); }
 298         ;
 299
 300 exp     :       '(' type ')' exp  %prec UNARY
 301                         { write_exp_elt_opcode (pstate, UNOP_CAST);
 302                           write_exp_elt_type (pstate, $2);
 303                           write_exp_elt_opcode (pstate, UNOP_CAST); }
 304         ;
 305
 306 exp     :       exp '%' name
 307                         { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 308                           write_exp_string (pstate, $3);
 309                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
 310         ;
 311
 312 /* Binary operators in order of decreasing precedence.  */
 313
 314 exp     :       exp '@' exp
 315                         { write_exp_elt_opcode (pstate, BINOP_REPEAT); }
 316         ;
 317
 318 exp     :       exp STARSTAR exp
 319                         { write_exp_elt_opcode (pstate, BINOP_EXP); }
 320         ;
 321
 322 exp     :       exp '*' exp
 323                         { write_exp_elt_opcode (pstate, BINOP_MUL); }
 324         ;
 325
 326 exp     :       exp '/' exp
 327                         { write_exp_elt_opcode (pstate, BINOP_DIV); }
 328         ;
 329
 330 exp     :       exp '+' exp
 331                         { write_exp_elt_opcode (pstate, BINOP_ADD); }
 332         ;
 333
 334 exp     :       exp '-' exp
 335                         { write_exp_elt_opcode (pstate, BINOP_SUB); }
 336         ;
 337
 338 exp     :       exp LSH exp
 339                         { write_exp_elt_opcode (pstate, BINOP_LSH); }
 340         ;
 341
 342 exp     :       exp RSH exp
 343                         { write_exp_elt_opcode (pstate, BINOP_RSH); }
 344         ;
 345
 346 exp     :       exp EQUAL exp
 347                         { write_exp_elt_opcode (pstate, BINOP_EQUAL); }
 348         ;
 349
 350 exp     :       exp NOTEQUAL exp
 351                         { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
 352         ;
 353
 354 exp     :       exp LEQ exp
 355                         { write_exp_elt_opcode (pstate, BINOP_LEQ); }
 356         ;
 357
 358 exp     :       exp GEQ exp
 359                         { write_exp_elt_opcode (pstate, BINOP_GEQ); }
 360         ;
 361
 362 exp     :       exp LESSTHAN exp
 363                         { write_exp_elt_opcode (pstate, BINOP_LESS); }
 364         ;
 365
 366 exp     :       exp GREATERTHAN exp
 367                         { write_exp_elt_opcode (pstate, BINOP_GTR); }
 368         ;
 369
 370 exp     :       exp '&' exp
 371                         { write_exp_elt_opcode (pstate, BINOP_BITWISE_AND); }
 372         ;
 373
 374 exp     :       exp '^' exp
 375                         { write_exp_elt_opcode (pstate, BINOP_BITWISE_XOR); }
 376         ;
 377
 378 exp     :       exp '|' exp
 379                         { write_exp_elt_opcode (pstate, BINOP_BITWISE_IOR); }
 380         ;
 381
 382 exp     :       exp BOOL_AND exp
 383                         { write_exp_elt_opcode (pstate, BINOP_LOGICAL_AND); }
 384         ;
 385
 386
 387 exp     :       exp BOOL_OR exp
 388                         { write_exp_elt_opcode (pstate, BINOP_LOGICAL_OR); }
 389         ;
 390
 391 exp     :       exp '=' exp
 392                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
 393         ;
 394
 395 exp     :       exp ASSIGN_MODIFY exp
 396                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
 397                           write_exp_elt_opcode (pstate, $2);
 398                           write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY); }
 399         ;
 400
 401 exp     :       INT
 402                         { write_exp_elt_opcode (pstate, OP_LONG);
 403                           write_exp_elt_type (pstate, $1.type);
 404                           write_exp_elt_longcst (pstate, (LONGEST) ($1.val));
 405                           write_exp_elt_opcode (pstate, OP_LONG); }
 406         ;
 407
 408 exp     :       NAME_OR_INT
 409                         { YYSTYPE val;
 410                           parse_number (pstate, $1.stoken.ptr,
 411                                         $1.stoken.length, 0, &val);
 412                           write_exp_elt_opcode (pstate, OP_LONG);
 413                           write_exp_elt_type (pstate, val.typed_val.type);
 414                           write_exp_elt_longcst (pstate,
 415                                                  (LONGEST)val.typed_val.val);
 416                           write_exp_elt_opcode (pstate, OP_LONG); }
 417         ;
 418
 419 exp     :       FLOAT
 420                         { write_exp_elt_opcode (pstate, OP_FLOAT);
 421                           write_exp_elt_type (pstate, $1.type);
 422                           write_exp_elt_floatcst (pstate, $1.val);
 423                           write_exp_elt_opcode (pstate, OP_FLOAT); }
 424         ;
 425
 426 exp     :       variable
 427         ;
 428
 429 exp     :       VARIABLE
 430         ;
 431
 432 exp     :       SIZEOF '(' type ')'     %prec UNARY
 433                         { write_exp_elt_opcode (pstate, OP_LONG);
 434                           write_exp_elt_type (pstate,
 435                                               parse_f_type (pstate)
 436                                               ->builtin_integer);
 437                           $3 = check_typedef ($3);
 438                           write_exp_elt_longcst (pstate,
 439                                                  (LONGEST) TYPE_LENGTH ($3));
 440                           write_exp_elt_opcode (pstate, OP_LONG); }
 441         ;
 442
 443 exp     :       BOOLEAN_LITERAL
 444                         { write_exp_elt_opcode (pstate, OP_BOOL);
 445                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 446                           write_exp_elt_opcode (pstate, OP_BOOL);
 447                         }
 448         ;
 449
 450 exp     :       STRING_LITERAL
 451                         {
 452                           write_exp_elt_opcode (pstate, OP_STRING);
 453                           write_exp_string (pstate, $1);
 454                           write_exp_elt_opcode (pstate, OP_STRING);
 455                         }
 456         ;
 457
 458 variable:       name_not_typename
 459                         { struct block_symbol sym = $1.sym;
 460
 461                           if (sym.symbol)
 462                             {
 463                               if (symbol_read_needs_frame (sym.symbol))
 464                                 innermost_block.update (sym);
 465                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 466                               write_exp_elt_block (pstate, sym.block);
 467                               write_exp_elt_sym (pstate, sym.symbol);
 468                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 469                               break;
 470                             }
 471                           else
 472                             {
 473                               struct bound_minimal_symbol msymbol;
 474                               char *arg = copy_name ($1.stoken);
 475
 476                               msymbol =
 477                                 lookup_bound_minimal_symbol (arg);
 478                               if (msymbol.minsym != NULL)
 479                                 write_exp_msymbol (pstate, msymbol);
 480                               else if (!have_full_symbols () && !have_partial_symbols ())
 481                                 error (_("No symbol table is loaded.  Use the \"file\" command."));
 482                               else
 483                                 error (_("No symbol \"%s\" in current context."),
 484                                        copy_name ($1.stoken));
 485                             }
 486                         }
 487         ;
 488
 489
 490 type    :       ptype
 491         ;
 492
 493 ptype   :       typebase
 494         |       typebase abs_decl
 495                 {
 496                   /* This is where the interesting stuff happens.  */
 497                   int done = 0;
 498                   int array_size;
 499                   struct type *follow_type = $1;
 500                   struct type *range_type;
 501
 502                   while (!done)
 503                     switch (pop_type ())
 504                       {
 505                       case tp_end:
 506                         done = 1;
 507                         break;
 508                       case tp_pointer:
 509                         follow_type = lookup_pointer_type (follow_type);
 510                         break;
 511                       case tp_reference:
 512                         follow_type = lookup_lvalue_reference_type (follow_type);
 513                         break;
 514                       case tp_array:
 515                         array_size = pop_type_int ();
 516                         if (array_size != -1)
 517                           {
 518                             range_type =
 519                               create_static_range_type ((struct type *) NULL,
 520                                                         parse_f_type (pstate)
 521                                                         ->builtin_integer,
 522                                                         0, array_size - 1);
 523                             follow_type =
 524                               create_array_type ((struct type *) NULL,
 525                                                  follow_type, range_type);
 526                           }
 527                         else
 528                           follow_type = lookup_pointer_type (follow_type);
 529                         break;
 530                       case tp_function:
 531                         follow_type = lookup_function_type (follow_type);
 532                         break;
 533                       }
 534                   $$ = follow_type;
 535                 }
 536         ;
 537
 538 abs_decl:       '*'
 539                         { push_type (tp_pointer); $$ = 0; }
 540         |       '*' abs_decl
 541                         { push_type (tp_pointer); $$ = $2; }
 542         |       '&'
 543                         { push_type (tp_reference); $$ = 0; }
 544         |       '&' abs_decl
 545                         { push_type (tp_reference); $$ = $2; }
 546         |       direct_abs_decl
 547         ;
 548
 549 direct_abs_decl: '(' abs_decl ')'
 550                         { $$ = $2; }
 551         |       direct_abs_decl func_mod
 552                         { push_type (tp_function); }
 553         |       func_mod
 554                         { push_type (tp_function); }
 555         ;
 556
 557 func_mod:       '(' ')'
 558                         { $$ = 0; }
 559         |       '(' nonempty_typelist ')'
 560                         { free ($2); $$ = 0; }
 561         ;
 562
 563 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 564         :       TYPENAME
 565                         { $$ = $1.type; }
 566         |       INT_KEYWORD
 567                         { $$ = parse_f_type (pstate)->builtin_integer; }
 568         |       INT_S2_KEYWORD
 569                         { $$ = parse_f_type (pstate)->builtin_integer_s2; }
 570         |       CHARACTER
 571                         { $$ = parse_f_type (pstate)->builtin_character; }
 572         |       LOGICAL_S8_KEYWORD
 573                         { $$ = parse_f_type (pstate)->builtin_logical_s8; }
 574         |       LOGICAL_KEYWORD
 575                         { $$ = parse_f_type (pstate)->builtin_logical; }
 576         |       LOGICAL_S2_KEYWORD
 577                         { $$ = parse_f_type (pstate)->builtin_logical_s2; }
 578         |       LOGICAL_S1_KEYWORD
 579                         { $$ = parse_f_type (pstate)->builtin_logical_s1; }
 580         |       REAL_KEYWORD
 581                         { $$ = parse_f_type (pstate)->builtin_real; }
 582         |       REAL_S8_KEYWORD
 583                         { $$ = parse_f_type (pstate)->builtin_real_s8; }
 584         |       REAL_S16_KEYWORD
 585                         { $$ = parse_f_type (pstate)->builtin_real_s16; }
 586         |       COMPLEX_S8_KEYWORD
 587                         { $$ = parse_f_type (pstate)->builtin_complex_s8; }
 588         |       COMPLEX_S16_KEYWORD
 589                         { $$ = parse_f_type (pstate)->builtin_complex_s16; }
 590         |       COMPLEX_S32_KEYWORD
 591                         { $$ = parse_f_type (pstate)->builtin_complex_s32; }
 592         ;
 593
 594 nonempty_typelist
 595         :       type
 596                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 597                   $<ivec>$[0] = 1;      /* Number of types in vector */
 598                   $$[1] = $1;
 599                 }
 600         |       nonempty_typelist ',' type
 601                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 602                   $$ = (struct type **) realloc ((char *) $1, len);
 603                   $$[$<ivec>$[0]] = $3;
 604                 }
 605         ;
 606
 607 name    :       NAME
 608                 {  $$ = $1.stoken; }
 609         ;
 610
 611 name_not_typename :     NAME
 612 /* These would be useful if name_not_typename was useful, but it is just
 613    a fake for "variable", so these cause reduce/reduce conflicts because
 614    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 615    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 616    context where only a name could occur, this might be useful.
 617         |       NAME_OR_INT
 618    */
 619         ;
 620
 621 %%
 622
 623 /* Take care of parsing a number (anything that starts with a digit).
 624    Set yylval and return the token type; update lexptr.
 625    LEN is the number of characters in it.  */
 626
 627 /*** Needs some error checking for the float case ***/
 628
 629 static int
 630 parse_number (struct parser_state *par_state,
 631               const char *p, int len, int parsed_float, YYSTYPE *putithere)
 632 {
 633   LONGEST n = 0;
 634   LONGEST prevn = 0;
 635   int c;
 636   int base = input_radix;
 637   int unsigned_p = 0;
 638   int long_p = 0;
 639   ULONGEST high_bit;
 640   struct type *signed_type;
 641   struct type *unsigned_type;
 642
 643   if (parsed_float)
 644     {
 645       /* It's a float since it contains a point or an exponent.  */
 646       /* [dD] is not understood as an exponent by parse_float,
 647          change it to 'e'.  */
 648       char *tmp, *tmp2;
 649
 650       tmp = xstrdup (p);
 651       for (tmp2 = tmp; *tmp2; ++tmp2)
 652         if (*tmp2 == 'd' || *tmp2 == 'D')
 653           *tmp2 = 'e';
 654
 655       /* FIXME: Should this use different types?  */
 656       putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
 657       bool parsed = parse_float (tmp, len,
 658                                  putithere->typed_val_float.type,
 659                                  putithere->typed_val_float.val);
 660       free (tmp);
 661       return parsed? FLOAT : ERROR;
 662     }
 663
 664   /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
 665   if (p[0] == '0')
 666     switch (p[1])
 667       {
 668       case 'x':
 669       case 'X':
 670         if (len >= 3)
 671           {
 672             p += 2;
 673             base = 16;
 674             len -= 2;
 675           }
 676         break;
 677
 678       case 't':
 679       case 'T':
 680       case 'd':
 681       case 'D':
 682         if (len >= 3)
 683           {
 684             p += 2;
 685             base = 10;
 686             len -= 2;
 687           }
 688         break;
 689
 690       default:
 691         base = 8;
 692         break;
 693       }
 694
 695   while (len-- > 0)
 696     {
 697       c = *p++;
 698       if (isupper (c))
 699         c = tolower (c);
 700       if (len == 0 && c == 'l')
 701         long_p = 1;
 702       else if (len == 0 && c == 'u')
 703         unsigned_p = 1;
 704       else
 705         {
 706           int i;
 707           if (c >= '0' && c <= '9')
 708             i = c - '0';
 709           else if (c >= 'a' && c <= 'f')
 710             i = c - 'a' + 10;
 711           else
 712             return ERROR;       /* Char not a digit */
 713           if (i >= base)
 714             return ERROR;               /* Invalid digit in this base */
 715           n *= base;
 716           n += i;
 717         }
 718       /* Portably test for overflow (only works for nonzero values, so make
 719          a second check for zero).  */
 720       if ((prevn >= n) && n != 0)
 721         unsigned_p=1;           /* Try something unsigned */
 722       /* If range checking enabled, portably test for unsigned overflow.  */
 723       if (RANGE_CHECK && n != 0)
 724         {
 725           if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
 726             range_error (_("Overflow on numeric constant."));
 727         }
 728       prevn = n;
 729     }
 730
 731   /* If the number is too big to be an int, or it's got an l suffix
 732      then it's a long.  Work out if this has to be a long by
 733      shifting right and seeing if anything remains, and the
 734      target int size is different to the target long size.
 735
 736      In the expression below, we could have tested
 737      (n >> gdbarch_int_bit (parse_gdbarch))
 738      to see if it was zero,
 739      but too many compilers warn about that, when ints and longs
 740      are the same size.  So we shift it twice, with fewer bits
 741      each time, for the same result.  */
 742
 743   if ((gdbarch_int_bit (parse_gdbarch (par_state))
 744        != gdbarch_long_bit (parse_gdbarch (par_state))
 745        && ((n >> 2)
 746            >> (gdbarch_int_bit (parse_gdbarch (par_state))-2))) /* Avoid
 747                                                             shift warning */
 748       || long_p)
 749     {
 750       high_bit = ((ULONGEST)1)
 751       << (gdbarch_long_bit (parse_gdbarch (par_state))-1);
 752       unsigned_type = parse_type (par_state)->builtin_unsigned_long;
 753       signed_type = parse_type (par_state)->builtin_long;
 754     }
 755   else
 756     {
 757       high_bit =
 758         ((ULONGEST)1) << (gdbarch_int_bit (parse_gdbarch (par_state)) - 1);
 759       unsigned_type = parse_type (par_state)->builtin_unsigned_int;
 760       signed_type = parse_type (par_state)->builtin_int;
 761     }
 762
 763   putithere->typed_val.val = n;
 764
 765   /* If the high bit of the worked out type is set then this number
 766      has to be unsigned.  */
 767
 768   if (unsigned_p || (n & high_bit))
 769     putithere->typed_val.type = unsigned_type;
 770   else
 771     putithere->typed_val.type = signed_type;
 772
 773   return INT;
 774 }
 775
 776 struct token
 777 {
 778   const char *oper;
 779   int token;
 780   enum exp_opcode opcode;
 781 };
 782
 783 static const struct token dot_ops[] =
 784 {
 785   { ".and.", BOOL_AND, BINOP_END },
 786   { ".AND.", BOOL_AND, BINOP_END },
 787   { ".or.", BOOL_OR, BINOP_END },
 788   { ".OR.", BOOL_OR, BINOP_END },
 789   { ".not.", BOOL_NOT, BINOP_END },
 790   { ".NOT.", BOOL_NOT, BINOP_END },
 791   { ".eq.", EQUAL, BINOP_END },
 792   { ".EQ.", EQUAL, BINOP_END },
 793   { ".eqv.", EQUAL, BINOP_END },
 794   { ".NEQV.", NOTEQUAL, BINOP_END },
 795   { ".neqv.", NOTEQUAL, BINOP_END },
 796   { ".EQV.", EQUAL, BINOP_END },
 797   { ".ne.", NOTEQUAL, BINOP_END },
 798   { ".NE.", NOTEQUAL, BINOP_END },
 799   { ".le.", LEQ, BINOP_END },
 800   { ".LE.", LEQ, BINOP_END },
 801   { ".ge.", GEQ, BINOP_END },
 802   { ".GE.", GEQ, BINOP_END },
 803   { ".gt.", GREATERTHAN, BINOP_END },
 804   { ".GT.", GREATERTHAN, BINOP_END },
 805   { ".lt.", LESSTHAN, BINOP_END },
 806   { ".LT.", LESSTHAN, BINOP_END },
 807   { NULL, 0, BINOP_END }
 808 };
 809
 810 struct f77_boolean_val
 811 {
 812   const char *name;
 813   int value;
 814 };
 815
 816 static const struct f77_boolean_val boolean_values[]  =
 817 {
 818   { ".true.", 1 },
 819   { ".TRUE.", 1 },
 820   { ".false.", 0 },
 821   { ".FALSE.", 0 },
 822   { NULL, 0 }
 823 };
 824
 825 static const struct token f77_keywords[] =
 826 {
 827   { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END },
 828   { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END },
 829   { "character", CHARACTER, BINOP_END },
 830   { "integer_2", INT_S2_KEYWORD, BINOP_END },
 831   { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END },
 832   { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END },
 833   { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END },
 834   { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END },
 835   { "integer", INT_KEYWORD, BINOP_END },
 836   { "logical", LOGICAL_KEYWORD, BINOP_END },
 837   { "real_16", REAL_S16_KEYWORD, BINOP_END },
 838   { "complex", COMPLEX_S8_KEYWORD, BINOP_END },
 839   { "sizeof", SIZEOF, BINOP_END },
 840   { "real_8", REAL_S8_KEYWORD, BINOP_END },
 841   { "real", REAL_KEYWORD, BINOP_END },
 842   { NULL, 0, BINOP_END }
 843 };
 844
 845 /* Implementation of a dynamically expandable buffer for processing input
 846    characters acquired through lexptr and building a value to return in
 847    yylval.  Ripped off from ch-exp.y */
 848
 849 static char *tempbuf;           /* Current buffer contents */
 850 static int tempbufsize;         /* Size of allocated buffer */
 851 static int tempbufindex;        /* Current index into buffer */
 852
 853 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
 854
 855 #define CHECKBUF(size) \
 856   do { \
 857     if (tempbufindex + (size) >= tempbufsize) \
 858       { \
 859         growbuf_by_size (size); \
 860       } \
 861   } while (0);
 862
 863
 864 /* Grow the static temp buffer if necessary, including allocating the
 865    first one on demand.  */
 866
 867 static void
 868 growbuf_by_size (int count)
 869 {
 870   int growby;
 871
 872   growby = std::max (count, GROWBY_MIN_SIZE);
 873   tempbufsize += growby;
 874   if (tempbuf == NULL)
 875     tempbuf = (char *) malloc (tempbufsize);
 876   else
 877     tempbuf = (char *) realloc (tempbuf, tempbufsize);
 878 }
 879
 880 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
 881    string-literals.
 882
 883    Recognize a string literal.  A string literal is a nonzero sequence
 884    of characters enclosed in matching single quotes, except that
 885    a single character inside single quotes is a character literal, which
 886    we reject as a string literal.  To embed the terminator character inside
 887    a string, it is simply doubled (I.E. 'this''is''one''string') */
 888
 889 static int
 890 match_string_literal (void)
 891 {
 892   const char *tokptr = lexptr;
 893
 894   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
 895     {
 896       CHECKBUF (1);
 897       if (*tokptr == *lexptr)
 898         {
 899           if (*(tokptr + 1) == *lexptr)
 900             tokptr++;
 901           else
 902             break;
 903         }
 904       tempbuf[tempbufindex++] = *tokptr;
 905     }
 906   if (*tokptr == '\0'                                   /* no terminator */
 907       || tempbufindex == 0)                             /* no string */
 908     return 0;
 909   else
 910     {
 911       tempbuf[tempbufindex] = '\0';
 912       yylval.sval.ptr = tempbuf;
 913       yylval.sval.length = tempbufindex;
 914       lexptr = ++tokptr;
 915       return STRING_LITERAL;
 916     }
 917 }
 918
 919 /* Read one token, getting characters through lexptr.  */
 920
 921 static int
 922 yylex (void)
 923 {
 924   int c;
 925   int namelen;
 926   unsigned int token;
 927   const char *tokstart;
 928
 929  retry:
 930
 931   prev_lexptr = lexptr;
 932
 933   tokstart = lexptr;
 934
 935   /* First of all, let us make sure we are not dealing with the
 936      special tokens .true. and .false. which evaluate to 1 and 0.  */
 937
 938   if (*lexptr == '.')
 939     {
 940       for (int i = 0; boolean_values[i].name != NULL; i++)
 941         {
 942           if (strncmp (tokstart, boolean_values[i].name,
 943                        strlen (boolean_values[i].name)) == 0)
 944             {
 945               lexptr += strlen (boolean_values[i].name);
 946               yylval.lval = boolean_values[i].value;
 947               return BOOLEAN_LITERAL;
 948             }
 949         }
 950     }
 951
 952   /* See if it is a special .foo. operator.  */
 953
 954   for (int i = 0; dot_ops[i].oper != NULL; i++)
 955     if (strncmp (tokstart, dot_ops[i].oper,
 956                  strlen (dot_ops[i].oper)) == 0)
 957       {
 958         lexptr += strlen (dot_ops[i].oper);
 959         yylval.opcode = dot_ops[i].opcode;
 960         return dot_ops[i].token;
 961       }
 962
 963   /* See if it is an exponentiation operator.  */
 964
 965   if (strncmp (tokstart, "**", 2) == 0)
 966     {
 967       lexptr += 2;
 968       yylval.opcode = BINOP_EXP;
 969       return STARSTAR;
 970     }
 971
 972   switch (c = *tokstart)
 973     {
 974     case 0:
 975       return 0;
 976
 977     case ' ':
 978     case '\t':
 979     case '\n':
 980       lexptr++;
 981       goto retry;
 982
 983     case '\'':
 984       token = match_string_literal ();
 985       if (token != 0)
 986         return (token);
 987       break;
 988
 989     case '(':
 990       paren_depth++;
 991       lexptr++;
 992       return c;
 993
 994     case ')':
 995       if (paren_depth == 0)
 996         return 0;
 997       paren_depth--;
 998       lexptr++;
 999       return c;
1000
1001     case ',':
1002       if (comma_terminates && paren_depth == 0)
1003         return 0;
1004       lexptr++;
1005       return c;
1006
1007     case '.':
1008       /* Might be a floating point number.  */
1009       if (lexptr[1] < '0' || lexptr[1] > '9')
1010         goto symbol;            /* Nope, must be a symbol.  */
1011       /* FALL THRU.  */
1012
1013     case '0':
1014     case '1':
1015     case '2':
1016     case '3':
1017     case '4':
1018     case '5':
1019     case '6':
1020     case '7':
1021     case '8':
1022     case '9':
1023       {
1024         /* It's a number.  */
1025         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1026         const char *p = tokstart;
1027         int hex = input_radix > 10;
1028
1029         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1030           {
1031             p += 2;
1032             hex = 1;
1033           }
1034         else if (c == '0' && (p[1]=='t' || p[1]=='T'
1035                               || p[1]=='d' || p[1]=='D'))
1036           {
1037             p += 2;
1038             hex = 0;
1039           }
1040
1041         for (;; ++p)
1042           {
1043             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1044               got_dot = got_e = 1;
1045             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1046               got_dot = got_d = 1;
1047             else if (!hex && !got_dot && *p == '.')
1048               got_dot = 1;
1049             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1050                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1051                      && (*p == '-' || *p == '+'))
1052               /* This is the sign of the exponent, not the end of the
1053                  number.  */
1054               continue;
1055             /* We will take any letters or digits.  parse_number will
1056                complain if past the radix, or if L or U are not final.  */
1057             else if ((*p < '0' || *p > '9')
1058                      && ((*p < 'a' || *p > 'z')
1059                          && (*p < 'A' || *p > 'Z')))
1060               break;
1061           }
1062         toktype = parse_number (pstate, tokstart, p - tokstart,
1063                                 got_dot|got_e|got_d,
1064                                 &yylval);
1065         if (toktype == ERROR)
1066           {
1067             char *err_copy = (char *) alloca (p - tokstart + 1);
1068
1069             memcpy (err_copy, tokstart, p - tokstart);
1070             err_copy[p - tokstart] = 0;
1071             error (_("Invalid number \"%s\"."), err_copy);
1072           }
1073         lexptr = p;
1074         return toktype;
1075       }
1076
1077     case '+':
1078     case '-':
1079     case '*':
1080     case '/':
1081     case '%':
1082     case '|':
1083     case '&':
1084     case '^':
1085     case '~':
1086     case '!':
1087     case '@':
1088     case '<':
1089     case '>':
1090     case '[':
1091     case ']':
1092     case '?':
1093     case ':':
1094     case '=':
1095     case '{':
1096     case '}':
1097     symbol:
1098       lexptr++;
1099       return c;
1100     }
1101
1102   if (!(c == '_' || c == '$' || c ==':'
1103         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1104     /* We must have come across a bad character (e.g. ';').  */
1105     error (_("Invalid character '%c' in expression."), c);
1106
1107   namelen = 0;
1108   for (c = tokstart[namelen];
1109        (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1110         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1111        c = tokstart[++namelen]);
1112
1113   /* The token "if" terminates the expression and is NOT
1114      removed from the input stream.  */
1115
1116   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1117     return 0;
1118
1119   lexptr += namelen;
1120
1121   /* Catch specific keywords.  */
1122
1123   for (int i = 0; f77_keywords[i].oper != NULL; i++)
1124     if (strlen (f77_keywords[i].oper) == namelen
1125         && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1126       {
1127         /*      lexptr += strlen(f77_keywords[i].operator); */
1128         yylval.opcode = f77_keywords[i].opcode;
1129         return f77_keywords[i].token;
1130       }
1131
1132   yylval.sval.ptr = tokstart;
1133   yylval.sval.length = namelen;
1134
1135   if (*tokstart == '$')
1136     {
1137       write_dollar_variable (pstate, yylval.sval);
1138       return VARIABLE;
1139     }
1140
1141   /* Use token-type TYPENAME for symbols that happen to be defined
1142      currently as names of types; NAME for other symbols.
1143      The caller is not constrained to care about the distinction.  */
1144   {
1145     char *tmp = copy_name (yylval.sval);
1146     struct block_symbol result;
1147     struct field_of_this_result is_a_field_of_this;
1148     enum domain_enum_tag lookup_domains[] =
1149     {
1150       STRUCT_DOMAIN,
1151       VAR_DOMAIN,
1152       MODULE_DOMAIN
1153     };
1154     int hextype;
1155
1156     for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1157       {
1158         /* Initialize this in case we *don't* use it in this call; that
1159            way we can refer to it unconditionally below.  */
1160         memset (&is_a_field_of_this, 0, sizeof (is_a_field_of_this));
1161
1162         result = lookup_symbol (tmp, expression_context_block,
1163                                 lookup_domains[i],
1164                                 parse_language (pstate)->la_language
1165                                 == language_cplus
1166                                   ? &is_a_field_of_this : NULL);
1167         if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1168           {
1169             yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1170             return TYPENAME;
1171           }
1172
1173         if (result.symbol)
1174           break;
1175       }
1176
1177     yylval.tsym.type
1178       = language_lookup_primitive_type (parse_language (pstate),
1179                                         parse_gdbarch (pstate), tmp);
1180     if (yylval.tsym.type != NULL)
1181       return TYPENAME;
1182
1183     /* Input names that aren't symbols but ARE valid hex numbers,
1184        when the input radix permits them, can be names or numbers
1185        depending on the parse.  Note we support radixes > 16 here.  */
1186     if (!result.symbol
1187         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1188             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1189       {
1190         YYSTYPE newlval;        /* Its value is ignored.  */
1191         hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1192         if (hextype == INT)
1193           {
1194             yylval.ssym.sym = result;
1195             yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1196             return NAME_OR_INT;
1197           }
1198       }
1199
1200     /* Any other kind of symbol */
1201     yylval.ssym.sym = result;
1202     yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1203     return NAME;
1204   }
1205 }
1206
1207 int
1208 f_parse (struct parser_state *par_state)
1209 {
1210   /* Setting up the parser state.  */
1211   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1212   gdb_assert (par_state != NULL);
1213   pstate = par_state;
1214
1215   return yyparse ();
1216 }
1217
1218 static void
1219 yyerror (const char *msg)
1220 {
1221   if (prev_lexptr)
1222     lexptr = prev_lexptr;
1223
1224   error (_("A %s in expression, near `%s'."), msg, lexptr);
1225 }