gdb/f-exp.y

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