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 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                                 {
 465                                   if (innermost_block == 0
 466                                       || contained_in (sym.block,
 467                                                        innermost_block))
 468                                     innermost_block = sym.block;
 469                                 }
 470                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 471                               write_exp_elt_block (pstate, sym.block);
 472                               write_exp_elt_sym (pstate, sym.symbol);
 473                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 474                               break;
 475                             }
 476                           else
 477                             {
 478                               struct bound_minimal_symbol msymbol;
 479                               char *arg = copy_name ($1.stoken);
 480
 481                               msymbol =
 482                                 lookup_bound_minimal_symbol (arg);
 483                               if (msymbol.minsym != NULL)
 484                                 write_exp_msymbol (pstate, msymbol);
 485                               else if (!have_full_symbols () && !have_partial_symbols ())
 486                                 error (_("No symbol table is loaded.  Use the \"file\" command."));
 487                               else
 488                                 error (_("No symbol \"%s\" in current context."),
 489                                        copy_name ($1.stoken));
 490                             }
 491                         }
 492         ;
 493
 494
 495 type    :       ptype
 496         ;
 497
 498 ptype   :       typebase
 499         |       typebase abs_decl
 500                 {
 501                   /* This is where the interesting stuff happens.  */
 502                   int done = 0;
 503                   int array_size;
 504                   struct type *follow_type = $1;
 505                   struct type *range_type;
 506
 507                   while (!done)
 508                     switch (pop_type ())
 509                       {
 510                       case tp_end:
 511                         done = 1;
 512                         break;
 513                       case tp_pointer:
 514                         follow_type = lookup_pointer_type (follow_type);
 515                         break;
 516                       case tp_reference:
 517                         follow_type = lookup_lvalue_reference_type (follow_type);
 518                         break;
 519                       case tp_array:
 520                         array_size = pop_type_int ();
 521                         if (array_size != -1)
 522                           {
 523                             range_type =
 524                               create_static_range_type ((struct type *) NULL,
 525                                                         parse_f_type (pstate)
 526                                                         ->builtin_integer,
 527                                                         0, array_size - 1);
 528                             follow_type =
 529                               create_array_type ((struct type *) NULL,
 530                                                  follow_type, range_type);
 531                           }
 532                         else
 533                           follow_type = lookup_pointer_type (follow_type);
 534                         break;
 535                       case tp_function:
 536                         follow_type = lookup_function_type (follow_type);
 537                         break;
 538                       }
 539                   $$ = follow_type;
 540                 }
 541         ;
 542
 543 abs_decl:       '*'
 544                         { push_type (tp_pointer); $$ = 0; }
 545         |       '*' abs_decl
 546                         { push_type (tp_pointer); $$ = $2; }
 547         |       '&'
 548                         { push_type (tp_reference); $$ = 0; }
 549         |       '&' abs_decl
 550                         { push_type (tp_reference); $$ = $2; }
 551         |       direct_abs_decl
 552         ;
 553
 554 direct_abs_decl: '(' abs_decl ')'
 555                         { $$ = $2; }
 556         |       direct_abs_decl func_mod
 557                         { push_type (tp_function); }
 558         |       func_mod
 559                         { push_type (tp_function); }
 560         ;
 561
 562 func_mod:       '(' ')'
 563                         { $$ = 0; }
 564         |       '(' nonempty_typelist ')'
 565                         { free ($2); $$ = 0; }
 566         ;
 567
 568 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 569         :       TYPENAME
 570                         { $$ = $1.type; }
 571         |       INT_KEYWORD
 572                         { $$ = parse_f_type (pstate)->builtin_integer; }
 573         |       INT_S2_KEYWORD
 574                         { $$ = parse_f_type (pstate)->builtin_integer_s2; }
 575         |       CHARACTER
 576                         { $$ = parse_f_type (pstate)->builtin_character; }
 577         |       LOGICAL_S8_KEYWORD
 578                         { $$ = parse_f_type (pstate)->builtin_logical_s8; }
 579         |       LOGICAL_KEYWORD
 580                         { $$ = parse_f_type (pstate)->builtin_logical; }
 581         |       LOGICAL_S2_KEYWORD
 582                         { $$ = parse_f_type (pstate)->builtin_logical_s2; }
 583         |       LOGICAL_S1_KEYWORD
 584                         { $$ = parse_f_type (pstate)->builtin_logical_s1; }
 585         |       REAL_KEYWORD
 586                         { $$ = parse_f_type (pstate)->builtin_real; }
 587         |       REAL_S8_KEYWORD
 588                         { $$ = parse_f_type (pstate)->builtin_real_s8; }
 589         |       REAL_S16_KEYWORD
 590                         { $$ = parse_f_type (pstate)->builtin_real_s16; }
 591         |       COMPLEX_S8_KEYWORD
 592                         { $$ = parse_f_type (pstate)->builtin_complex_s8; }
 593         |       COMPLEX_S16_KEYWORD
 594                         { $$ = parse_f_type (pstate)->builtin_complex_s16; }
 595         |       COMPLEX_S32_KEYWORD
 596                         { $$ = parse_f_type (pstate)->builtin_complex_s32; }
 597         ;
 598
 599 nonempty_typelist
 600         :       type
 601                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 602                   $<ivec>$[0] = 1;      /* Number of types in vector */
 603                   $$[1] = $1;
 604                 }
 605         |       nonempty_typelist ',' type
 606                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 607                   $$ = (struct type **) realloc ((char *) $1, len);
 608                   $$[$<ivec>$[0]] = $3;
 609                 }
 610         ;
 611
 612 name    :       NAME
 613                 {  $$ = $1.stoken; }
 614         ;
 615
 616 name_not_typename :     NAME
 617 /* These would be useful if name_not_typename was useful, but it is just
 618    a fake for "variable", so these cause reduce/reduce conflicts because
 619    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 620    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 621    context where only a name could occur, this might be useful.
 622         |       NAME_OR_INT
 623    */
 624         ;
 625
 626 %%
 627
 628 /* Take care of parsing a number (anything that starts with a digit).
 629    Set yylval and return the token type; update lexptr.
 630    LEN is the number of characters in it.  */
 631
 632 /*** Needs some error checking for the float case ***/
 633
 634 static int
 635 parse_number (struct parser_state *par_state,
 636               const char *p, int len, int parsed_float, YYSTYPE *putithere)
 637 {
 638   LONGEST n = 0;
 639   LONGEST prevn = 0;
 640   int c;
 641   int base = input_radix;
 642   int unsigned_p = 0;
 643   int long_p = 0;
 644   ULONGEST high_bit;
 645   struct type *signed_type;
 646   struct type *unsigned_type;
 647
 648   if (parsed_float)
 649     {
 650       /* It's a float since it contains a point or an exponent.  */
 651       /* [dD] is not understood as an exponent by parse_float,
 652          change it to 'e'.  */
 653       char *tmp, *tmp2;
 654
 655       tmp = xstrdup (p);
 656       for (tmp2 = tmp; *tmp2; ++tmp2)
 657         if (*tmp2 == 'd' || *tmp2 == 'D')
 658           *tmp2 = 'e';
 659
 660       /* FIXME: Should this use different types?  */
 661       putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
 662       bool parsed = parse_float (tmp, len,
 663                                  putithere->typed_val_float.type,
 664                                  putithere->typed_val_float.val);
 665       free (tmp);
 666       return parsed? FLOAT : ERROR;
 667     }
 668
 669   /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
 670   if (p[0] == '0')
 671     switch (p[1])
 672       {
 673       case 'x':
 674       case 'X':
 675         if (len >= 3)
 676           {
 677             p += 2;
 678             base = 16;
 679             len -= 2;
 680           }
 681         break;
 682
 683       case 't':
 684       case 'T':
 685       case 'd':
 686       case 'D':
 687         if (len >= 3)
 688           {
 689             p += 2;
 690             base = 10;
 691             len -= 2;
 692           }
 693         break;
 694
 695       default:
 696         base = 8;
 697         break;
 698       }
 699
 700   while (len-- > 0)
 701     {
 702       c = *p++;
 703       if (isupper (c))
 704         c = tolower (c);
 705       if (len == 0 && c == 'l')
 706         long_p = 1;
 707       else if (len == 0 && c == 'u')
 708         unsigned_p = 1;
 709       else
 710         {
 711           int i;
 712           if (c >= '0' && c <= '9')
 713             i = c - '0';
 714           else if (c >= 'a' && c <= 'f')
 715             i = c - 'a' + 10;
 716           else
 717             return ERROR;       /* Char not a digit */
 718           if (i >= base)
 719             return ERROR;               /* Invalid digit in this base */
 720           n *= base;
 721           n += i;
 722         }
 723       /* Portably test for overflow (only works for nonzero values, so make
 724          a second check for zero).  */
 725       if ((prevn >= n) && n != 0)
 726         unsigned_p=1;           /* Try something unsigned */
 727       /* If range checking enabled, portably test for unsigned overflow.  */
 728       if (RANGE_CHECK && n != 0)
 729         {
 730           if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
 731             range_error (_("Overflow on numeric constant."));
 732         }
 733       prevn = n;
 734     }
 735
 736   /* If the number is too big to be an int, or it's got an l suffix
 737      then it's a long.  Work out if this has to be a long by
 738      shifting right and seeing if anything remains, and the
 739      target int size is different to the target long size.
 740
 741      In the expression below, we could have tested
 742      (n >> gdbarch_int_bit (parse_gdbarch))
 743      to see if it was zero,
 744      but too many compilers warn about that, when ints and longs
 745      are the same size.  So we shift it twice, with fewer bits
 746      each time, for the same result.  */
 747
 748   if ((gdbarch_int_bit (parse_gdbarch (par_state))
 749        != gdbarch_long_bit (parse_gdbarch (par_state))
 750        && ((n >> 2)
 751            >> (gdbarch_int_bit (parse_gdbarch (par_state))-2))) /* Avoid
 752                                                             shift warning */
 753       || long_p)
 754     {
 755       high_bit = ((ULONGEST)1)
 756       << (gdbarch_long_bit (parse_gdbarch (par_state))-1);
 757       unsigned_type = parse_type (par_state)->builtin_unsigned_long;
 758       signed_type = parse_type (par_state)->builtin_long;
 759     }
 760   else
 761     {
 762       high_bit =
 763         ((ULONGEST)1) << (gdbarch_int_bit (parse_gdbarch (par_state)) - 1);
 764       unsigned_type = parse_type (par_state)->builtin_unsigned_int;
 765       signed_type = parse_type (par_state)->builtin_int;
 766     }
 767
 768   putithere->typed_val.val = n;
 769
 770   /* If the high bit of the worked out type is set then this number
 771      has to be unsigned.  */
 772
 773   if (unsigned_p || (n & high_bit))
 774     putithere->typed_val.type = unsigned_type;
 775   else
 776     putithere->typed_val.type = signed_type;
 777
 778   return INT;
 779 }
 780
 781 struct token
 782 {
 783   const char *oper;
 784   int token;
 785   enum exp_opcode opcode;
 786 };
 787
 788 static const struct token dot_ops[] =
 789 {
 790   { ".and.", BOOL_AND, BINOP_END },
 791   { ".AND.", BOOL_AND, BINOP_END },
 792   { ".or.", BOOL_OR, BINOP_END },
 793   { ".OR.", BOOL_OR, BINOP_END },
 794   { ".not.", BOOL_NOT, BINOP_END },
 795   { ".NOT.", BOOL_NOT, BINOP_END },
 796   { ".eq.", EQUAL, BINOP_END },
 797   { ".EQ.", EQUAL, BINOP_END },
 798   { ".eqv.", EQUAL, BINOP_END },
 799   { ".NEQV.", NOTEQUAL, BINOP_END },
 800   { ".neqv.", NOTEQUAL, BINOP_END },
 801   { ".EQV.", EQUAL, BINOP_END },
 802   { ".ne.", NOTEQUAL, BINOP_END },
 803   { ".NE.", NOTEQUAL, BINOP_END },
 804   { ".le.", LEQ, BINOP_END },
 805   { ".LE.", LEQ, BINOP_END },
 806   { ".ge.", GEQ, BINOP_END },
 807   { ".GE.", GEQ, BINOP_END },
 808   { ".gt.", GREATERTHAN, BINOP_END },
 809   { ".GT.", GREATERTHAN, BINOP_END },
 810   { ".lt.", LESSTHAN, BINOP_END },
 811   { ".LT.", LESSTHAN, BINOP_END },
 812   { NULL, 0, BINOP_END }
 813 };
 814
 815 struct f77_boolean_val
 816 {
 817   const char *name;
 818   int value;
 819 };
 820
 821 static const struct f77_boolean_val boolean_values[]  =
 822 {
 823   { ".true.", 1 },
 824   { ".TRUE.", 1 },
 825   { ".false.", 0 },
 826   { ".FALSE.", 0 },
 827   { NULL, 0 }
 828 };
 829
 830 static const struct token f77_keywords[] =
 831 {
 832   { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END },
 833   { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END },
 834   { "character", CHARACTER, BINOP_END },
 835   { "integer_2", INT_S2_KEYWORD, BINOP_END },
 836   { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END },
 837   { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END },
 838   { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END },
 839   { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END },
 840   { "integer", INT_KEYWORD, BINOP_END },
 841   { "logical", LOGICAL_KEYWORD, BINOP_END },
 842   { "real_16", REAL_S16_KEYWORD, BINOP_END },
 843   { "complex", COMPLEX_S8_KEYWORD, BINOP_END },
 844   { "sizeof", SIZEOF, BINOP_END },
 845   { "real_8", REAL_S8_KEYWORD, BINOP_END },
 846   { "real", REAL_KEYWORD, BINOP_END },
 847   { NULL, 0, BINOP_END }
 848 };
 849
 850 /* Implementation of a dynamically expandable buffer for processing input
 851    characters acquired through lexptr and building a value to return in
 852    yylval.  Ripped off from ch-exp.y */
 853
 854 static char *tempbuf;           /* Current buffer contents */
 855 static int tempbufsize;         /* Size of allocated buffer */
 856 static int tempbufindex;        /* Current index into buffer */
 857
 858 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
 859
 860 #define CHECKBUF(size) \
 861   do { \
 862     if (tempbufindex + (size) >= tempbufsize) \
 863       { \
 864         growbuf_by_size (size); \
 865       } \
 866   } while (0);
 867
 868
 869 /* Grow the static temp buffer if necessary, including allocating the
 870    first one on demand.  */
 871
 872 static void
 873 growbuf_by_size (int count)
 874 {
 875   int growby;
 876
 877   growby = std::max (count, GROWBY_MIN_SIZE);
 878   tempbufsize += growby;
 879   if (tempbuf == NULL)
 880     tempbuf = (char *) malloc (tempbufsize);
 881   else
 882     tempbuf = (char *) realloc (tempbuf, tempbufsize);
 883 }
 884
 885 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
 886    string-literals.
 887
 888    Recognize a string literal.  A string literal is a nonzero sequence
 889    of characters enclosed in matching single quotes, except that
 890    a single character inside single quotes is a character literal, which
 891    we reject as a string literal.  To embed the terminator character inside
 892    a string, it is simply doubled (I.E. 'this''is''one''string') */
 893
 894 static int
 895 match_string_literal (void)
 896 {
 897   const char *tokptr = lexptr;
 898
 899   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
 900     {
 901       CHECKBUF (1);
 902       if (*tokptr == *lexptr)
 903         {
 904           if (*(tokptr + 1) == *lexptr)
 905             tokptr++;
 906           else
 907             break;
 908         }
 909       tempbuf[tempbufindex++] = *tokptr;
 910     }
 911   if (*tokptr == '\0'                                   /* no terminator */
 912       || tempbufindex == 0)                             /* no string */
 913     return 0;
 914   else
 915     {
 916       tempbuf[tempbufindex] = '\0';
 917       yylval.sval.ptr = tempbuf;
 918       yylval.sval.length = tempbufindex;
 919       lexptr = ++tokptr;
 920       return STRING_LITERAL;
 921     }
 922 }
 923
 924 /* Read one token, getting characters through lexptr.  */
 925
 926 static int
 927 yylex (void)
 928 {
 929   int c;
 930   int namelen;
 931   unsigned int i,token;
 932   const char *tokstart;
 933
 934  retry:
 935
 936   prev_lexptr = lexptr;
 937
 938   tokstart = lexptr;
 939
 940   /* First of all, let us make sure we are not dealing with the
 941      special tokens .true. and .false. which evaluate to 1 and 0.  */
 942
 943   if (*lexptr == '.')
 944     {
 945       for (i = 0; boolean_values[i].name != NULL; i++)
 946         {
 947           if (strncmp (tokstart, boolean_values[i].name,
 948                        strlen (boolean_values[i].name)) == 0)
 949             {
 950               lexptr += strlen (boolean_values[i].name);
 951               yylval.lval = boolean_values[i].value;
 952               return BOOLEAN_LITERAL;
 953             }
 954         }
 955     }
 956
 957   /* See if it is a special .foo. operator.  */
 958
 959   for (i = 0; dot_ops[i].oper != NULL; i++)
 960     if (strncmp (tokstart, dot_ops[i].oper,
 961                  strlen (dot_ops[i].oper)) == 0)
 962       {
 963         lexptr += strlen (dot_ops[i].oper);
 964         yylval.opcode = dot_ops[i].opcode;
 965         return dot_ops[i].token;
 966       }
 967
 968   /* See if it is an exponentiation operator.  */
 969
 970   if (strncmp (tokstart, "**", 2) == 0)
 971     {
 972       lexptr += 2;
 973       yylval.opcode = BINOP_EXP;
 974       return STARSTAR;
 975     }
 976
 977   switch (c = *tokstart)
 978     {
 979     case 0:
 980       return 0;
 981
 982     case ' ':
 983     case '\t':
 984     case '\n':
 985       lexptr++;
 986       goto retry;
 987
 988     case '\'':
 989       token = match_string_literal ();
 990       if (token != 0)
 991         return (token);
 992       break;
 993
 994     case '(':
 995       paren_depth++;
 996       lexptr++;
 997       return c;
 998
 999     case ')':
1000       if (paren_depth == 0)
1001         return 0;
1002       paren_depth--;
1003       lexptr++;
1004       return c;
1005
1006     case ',':
1007       if (comma_terminates && paren_depth == 0)
1008         return 0;
1009       lexptr++;
1010       return c;
1011
1012     case '.':
1013       /* Might be a floating point number.  */
1014       if (lexptr[1] < '0' || lexptr[1] > '9')
1015         goto symbol;            /* Nope, must be a symbol.  */
1016       /* FALL THRU into number case.  */
1017
1018     case '0':
1019     case '1':
1020     case '2':
1021     case '3':
1022     case '4':
1023     case '5':
1024     case '6':
1025     case '7':
1026     case '8':
1027     case '9':
1028       {
1029         /* It's a number.  */
1030         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1031         const char *p = tokstart;
1032         int hex = input_radix > 10;
1033
1034         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1035           {
1036             p += 2;
1037             hex = 1;
1038           }
1039         else if (c == '0' && (p[1]=='t' || p[1]=='T'
1040                               || p[1]=='d' || p[1]=='D'))
1041           {
1042             p += 2;
1043             hex = 0;
1044           }
1045
1046         for (;; ++p)
1047           {
1048             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1049               got_dot = got_e = 1;
1050             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1051               got_dot = got_d = 1;
1052             else if (!hex && !got_dot && *p == '.')
1053               got_dot = 1;
1054             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1055                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1056                      && (*p == '-' || *p == '+'))
1057               /* This is the sign of the exponent, not the end of the
1058                  number.  */
1059               continue;
1060             /* We will take any letters or digits.  parse_number will
1061                complain if past the radix, or if L or U are not final.  */
1062             else if ((*p < '0' || *p > '9')
1063                      && ((*p < 'a' || *p > 'z')
1064                          && (*p < 'A' || *p > 'Z')))
1065               break;
1066           }
1067         toktype = parse_number (pstate, tokstart, p - tokstart,
1068                                 got_dot|got_e|got_d,
1069                                 &yylval);
1070         if (toktype == ERROR)
1071           {
1072             char *err_copy = (char *) alloca (p - tokstart + 1);
1073
1074             memcpy (err_copy, tokstart, p - tokstart);
1075             err_copy[p - tokstart] = 0;
1076             error (_("Invalid number \"%s\"."), err_copy);
1077           }
1078         lexptr = p;
1079         return toktype;
1080       }
1081
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     case '?':
1098     case ':':
1099     case '=':
1100     case '{':
1101     case '}':
1102     symbol:
1103       lexptr++;
1104       return c;
1105     }
1106
1107   if (!(c == '_' || c == '$' || c ==':'
1108         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1109     /* We must have come across a bad character (e.g. ';').  */
1110     error (_("Invalid character '%c' in expression."), c);
1111
1112   namelen = 0;
1113   for (c = tokstart[namelen];
1114        (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1115         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1116        c = tokstart[++namelen]);
1117
1118   /* The token "if" terminates the expression and is NOT
1119      removed from the input stream.  */
1120
1121   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1122     return 0;
1123
1124   lexptr += namelen;
1125
1126   /* Catch specific keywords.  */
1127
1128   for (i = 0; f77_keywords[i].oper != NULL; i++)
1129     if (strlen (f77_keywords[i].oper) == namelen
1130         && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1131       {
1132         /*      lexptr += strlen(f77_keywords[i].operator); */
1133         yylval.opcode = f77_keywords[i].opcode;
1134         return f77_keywords[i].token;
1135       }
1136
1137   yylval.sval.ptr = tokstart;
1138   yylval.sval.length = namelen;
1139
1140   if (*tokstart == '$')
1141     {
1142       write_dollar_variable (pstate, yylval.sval);
1143       return VARIABLE;
1144     }
1145
1146   /* Use token-type TYPENAME for symbols that happen to be defined
1147      currently as names of types; NAME for other symbols.
1148      The caller is not constrained to care about the distinction.  */
1149   {
1150     char *tmp = copy_name (yylval.sval);
1151     struct block_symbol result;
1152     struct field_of_this_result is_a_field_of_this;
1153     enum domain_enum_tag lookup_domains[] =
1154     {
1155       STRUCT_DOMAIN,
1156       VAR_DOMAIN,
1157       MODULE_DOMAIN
1158     };
1159     int i;
1160     int hextype;
1161
1162     for (i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1163       {
1164         /* Initialize this in case we *don't* use it in this call; that
1165            way we can refer to it unconditionally below.  */
1166         memset (&is_a_field_of_this, 0, sizeof (is_a_field_of_this));
1167
1168         result = lookup_symbol (tmp, expression_context_block,
1169                                 lookup_domains[i],
1170                                 parse_language (pstate)->la_language
1171                                 == language_cplus
1172                                   ? &is_a_field_of_this : NULL);
1173         if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1174           {
1175             yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1176             return TYPENAME;
1177           }
1178
1179         if (result.symbol)
1180           break;
1181       }
1182
1183     yylval.tsym.type
1184       = language_lookup_primitive_type (parse_language (pstate),
1185                                         parse_gdbarch (pstate), tmp);
1186     if (yylval.tsym.type != NULL)
1187       return TYPENAME;
1188
1189     /* Input names that aren't symbols but ARE valid hex numbers,
1190        when the input radix permits them, can be names or numbers
1191        depending on the parse.  Note we support radixes > 16 here.  */
1192     if (!result.symbol
1193         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1194             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1195       {
1196         YYSTYPE newlval;        /* Its value is ignored.  */
1197         hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1198         if (hextype == INT)
1199           {
1200             yylval.ssym.sym = result;
1201             yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1202             return NAME_OR_INT;
1203           }
1204       }
1205
1206     /* Any other kind of symbol */
1207     yylval.ssym.sym = result;
1208     yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1209     return NAME;
1210   }
1211 }
1212
1213 int
1214 f_parse (struct parser_state *par_state)
1215 {
1216   /* Setting up the parser state.  */
1217   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1218   gdb_assert (par_state != NULL);
1219   pstate = par_state;
1220
1221   return yyparse ();
1222 }
1223
1224 void
1225 yyerror (const char *msg)
1226 {
1227   if (prev_lexptr)
1228     lexptr = prev_lexptr;
1229
1230   error (_("A %s in expression, near `%s'."), (msg ? msg : "error"), lexptr);
1231 }