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       else if (kind == 8)
 869         return parse_f_type (pstate)->builtin_integer_s8;
 870     }
 871
 872   error (_("unsupported kind %d for type %s"),
 873          kind, TYPE_SAFE_NAME (basetype));
 874
 875   /* Should never get here.  */
 876   return nullptr;
 877 }
 878
 879 struct token
 880 {
 881   /* The string to match against.  */
 882   const char *oper;
 883
 884   /* The lexer token to return.  */
 885   int token;
 886
 887   /* The expression opcode to embed within the token.  */
 888   enum exp_opcode opcode;
 889
 890   /* When this is true the string in OPER is matched exactly including
 891      case, when this is false OPER is matched case insensitively.  */
 892   bool case_sensitive;
 893 };
 894
 895 static const struct token dot_ops[] =
 896 {
 897   { ".and.", BOOL_AND, BINOP_END, false },
 898   { ".or.", BOOL_OR, BINOP_END, false },
 899   { ".not.", BOOL_NOT, BINOP_END, false },
 900   { ".eq.", EQUAL, BINOP_END, false },
 901   { ".eqv.", EQUAL, BINOP_END, false },
 902   { ".neqv.", NOTEQUAL, BINOP_END, false },
 903   { ".ne.", NOTEQUAL, BINOP_END, false },
 904   { ".le.", LEQ, BINOP_END, false },
 905   { ".ge.", GEQ, BINOP_END, false },
 906   { ".gt.", GREATERTHAN, BINOP_END, false },
 907   { ".lt.", LESSTHAN, BINOP_END, false },
 908 };
 909
 910 /* Holds the Fortran representation of a boolean, and the integer value we
 911    substitute in when one of the matching strings is parsed.  */
 912 struct f77_boolean_val
 913 {
 914   /* The string representing a Fortran boolean.  */
 915   const char *name;
 916
 917   /* The integer value to replace it with.  */
 918   int value;
 919 };
 920
 921 /* The set of Fortran booleans.  These are matched case insensitively.  */
 922 static const struct f77_boolean_val boolean_values[]  =
 923 {
 924   { ".true.", 1 },
 925   { ".false.", 0 }
 926 };
 927
 928 static const struct token f77_keywords[] =
 929 {
 930   /* Historically these have always been lowercase only in GDB.  */
 931   { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END, true },
 932   { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END, true },
 933   { "character", CHARACTER, BINOP_END, true },
 934   { "integer_2", INT_S2_KEYWORD, BINOP_END, true },
 935   { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END, true },
 936   { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END, true },
 937   { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END, true },
 938   { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END, true },
 939   { "integer", INT_KEYWORD, BINOP_END, true },
 940   { "logical", LOGICAL_KEYWORD, BINOP_END, true },
 941   { "real_16", REAL_S16_KEYWORD, BINOP_END, true },
 942   { "complex", COMPLEX_S8_KEYWORD, BINOP_END, true },
 943   { "sizeof", SIZEOF, BINOP_END, true },
 944   { "real_8", REAL_S8_KEYWORD, BINOP_END, true },
 945   { "real", REAL_KEYWORD, BINOP_END, true },
 946   /* The following correspond to actual functions in Fortran and are case
 947      insensitive.  */
 948   { "kind", KIND, BINOP_END, false }
 949 };
 950
 951 /* Implementation of a dynamically expandable buffer for processing input
 952    characters acquired through lexptr and building a value to return in
 953    yylval.  Ripped off from ch-exp.y */
 954
 955 static char *tempbuf;           /* Current buffer contents */
 956 static int tempbufsize;         /* Size of allocated buffer */
 957 static int tempbufindex;        /* Current index into buffer */
 958
 959 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
 960
 961 #define CHECKBUF(size) \
 962   do { \
 963     if (tempbufindex + (size) >= tempbufsize) \
 964       { \
 965         growbuf_by_size (size); \
 966       } \
 967   } while (0);
 968
 969
 970 /* Grow the static temp buffer if necessary, including allocating the
 971    first one on demand.  */
 972
 973 static void
 974 growbuf_by_size (int count)
 975 {
 976   int growby;
 977
 978   growby = std::max (count, GROWBY_MIN_SIZE);
 979   tempbufsize += growby;
 980   if (tempbuf == NULL)
 981     tempbuf = (char *) malloc (tempbufsize);
 982   else
 983     tempbuf = (char *) realloc (tempbuf, tempbufsize);
 984 }
 985
 986 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
 987    string-literals.
 988
 989    Recognize a string literal.  A string literal is a nonzero sequence
 990    of characters enclosed in matching single quotes, except that
 991    a single character inside single quotes is a character literal, which
 992    we reject as a string literal.  To embed the terminator character inside
 993    a string, it is simply doubled (I.E. 'this''is''one''string') */
 994
 995 static int
 996 match_string_literal (void)
 997 {
 998   const char *tokptr = lexptr;
 999
1000   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1001     {
1002       CHECKBUF (1);
1003       if (*tokptr == *lexptr)
1004         {
1005           if (*(tokptr + 1) == *lexptr)
1006             tokptr++;
1007           else
1008             break;
1009         }
1010       tempbuf[tempbufindex++] = *tokptr;
1011     }
1012   if (*tokptr == '\0'                                   /* no terminator */
1013       || tempbufindex == 0)                             /* no string */
1014     return 0;
1015   else
1016     {
1017       tempbuf[tempbufindex] = '\0';
1018       yylval.sval.ptr = tempbuf;
1019       yylval.sval.length = tempbufindex;
1020       lexptr = ++tokptr;
1021       return STRING_LITERAL;
1022     }
1023 }
1024
1025 /* Read one token, getting characters through lexptr.  */
1026
1027 static int
1028 yylex (void)
1029 {
1030   int c;
1031   int namelen;
1032   unsigned int token;
1033   const char *tokstart;
1034
1035  retry:
1036
1037   prev_lexptr = lexptr;
1038
1039   tokstart = lexptr;
1040
1041   /* First of all, let us make sure we are not dealing with the
1042      special tokens .true. and .false. which evaluate to 1 and 0.  */
1043
1044   if (*lexptr == '.')
1045     {
1046       for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1047         {
1048           if (strncasecmp (tokstart, boolean_values[i].name,
1049                            strlen (boolean_values[i].name)) == 0)
1050             {
1051               lexptr += strlen (boolean_values[i].name);
1052               yylval.lval = boolean_values[i].value;
1053               return BOOLEAN_LITERAL;
1054             }
1055         }
1056     }
1057
1058   /* See if it is a special .foo. operator.  */
1059   for (int i = 0; i < ARRAY_SIZE (dot_ops); i++)
1060     if (strncasecmp (tokstart, dot_ops[i].oper,
1061                      strlen (dot_ops[i].oper)) == 0)
1062       {
1063         gdb_assert (!dot_ops[i].case_sensitive);
1064         lexptr += strlen (dot_ops[i].oper);
1065         yylval.opcode = dot_ops[i].opcode;
1066         return dot_ops[i].token;
1067       }
1068
1069   /* See if it is an exponentiation operator.  */
1070
1071   if (strncmp (tokstart, "**", 2) == 0)
1072     {
1073       lexptr += 2;
1074       yylval.opcode = BINOP_EXP;
1075       return STARSTAR;
1076     }
1077
1078   switch (c = *tokstart)
1079     {
1080     case 0:
1081       return 0;
1082
1083     case ' ':
1084     case '\t':
1085     case '\n':
1086       lexptr++;
1087       goto retry;
1088
1089     case '\'':
1090       token = match_string_literal ();
1091       if (token != 0)
1092         return (token);
1093       break;
1094
1095     case '(':
1096       paren_depth++;
1097       lexptr++;
1098       return c;
1099
1100     case ')':
1101       if (paren_depth == 0)
1102         return 0;
1103       paren_depth--;
1104       lexptr++;
1105       return c;
1106
1107     case ',':
1108       if (comma_terminates && paren_depth == 0)
1109         return 0;
1110       lexptr++;
1111       return c;
1112
1113     case '.':
1114       /* Might be a floating point number.  */
1115       if (lexptr[1] < '0' || lexptr[1] > '9')
1116         goto symbol;            /* Nope, must be a symbol.  */
1117       /* FALL THRU.  */
1118
1119     case '0':
1120     case '1':
1121     case '2':
1122     case '3':
1123     case '4':
1124     case '5':
1125     case '6':
1126     case '7':
1127     case '8':
1128     case '9':
1129       {
1130         /* It's a number.  */
1131         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1132         const char *p = tokstart;
1133         int hex = input_radix > 10;
1134
1135         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1136           {
1137             p += 2;
1138             hex = 1;
1139           }
1140         else if (c == '0' && (p[1]=='t' || p[1]=='T'
1141                               || p[1]=='d' || p[1]=='D'))
1142           {
1143             p += 2;
1144             hex = 0;
1145           }
1146
1147         for (;; ++p)
1148           {
1149             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1150               got_dot = got_e = 1;
1151             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1152               got_dot = got_d = 1;
1153             else if (!hex && !got_dot && *p == '.')
1154               got_dot = 1;
1155             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1156                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1157                      && (*p == '-' || *p == '+'))
1158               /* This is the sign of the exponent, not the end of the
1159                  number.  */
1160               continue;
1161             /* We will take any letters or digits.  parse_number will
1162                complain if past the radix, or if L or U are not final.  */
1163             else if ((*p < '0' || *p > '9')
1164                      && ((*p < 'a' || *p > 'z')
1165                          && (*p < 'A' || *p > 'Z')))
1166               break;
1167           }
1168         toktype = parse_number (pstate, tokstart, p - tokstart,
1169                                 got_dot|got_e|got_d,
1170                                 &yylval);
1171         if (toktype == ERROR)
1172           {
1173             char *err_copy = (char *) alloca (p - tokstart + 1);
1174
1175             memcpy (err_copy, tokstart, p - tokstart);
1176             err_copy[p - tokstart] = 0;
1177             error (_("Invalid number \"%s\"."), err_copy);
1178           }
1179         lexptr = p;
1180         return toktype;
1181       }
1182
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     case '{':
1202     case '}':
1203     symbol:
1204       lexptr++;
1205       return c;
1206     }
1207
1208   if (!(c == '_' || c == '$' || c ==':'
1209         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1210     /* We must have come across a bad character (e.g. ';').  */
1211     error (_("Invalid character '%c' in expression."), c);
1212
1213   namelen = 0;
1214   for (c = tokstart[namelen];
1215        (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1216         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1217        c = tokstart[++namelen]);
1218
1219   /* The token "if" terminates the expression and is NOT
1220      removed from the input stream.  */
1221
1222   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1223     return 0;
1224
1225   lexptr += namelen;
1226
1227   /* Catch specific keywords.  */
1228
1229   for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1230     if (strlen (f77_keywords[i].oper) == namelen
1231         && ((!f77_keywords[i].case_sensitive
1232              && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1233             || (f77_keywords[i].case_sensitive
1234                 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1235       {
1236         yylval.opcode = f77_keywords[i].opcode;
1237         return f77_keywords[i].token;
1238       }
1239
1240   yylval.sval.ptr = tokstart;
1241   yylval.sval.length = namelen;
1242
1243   if (*tokstart == '$')
1244     {
1245       write_dollar_variable (pstate, yylval.sval);
1246       return DOLLAR_VARIABLE;
1247     }
1248
1249   /* Use token-type TYPENAME for symbols that happen to be defined
1250      currently as names of types; NAME for other symbols.
1251      The caller is not constrained to care about the distinction.  */
1252   {
1253     char *tmp = copy_name (yylval.sval);
1254     struct block_symbol result;
1255     struct field_of_this_result is_a_field_of_this;
1256     enum domain_enum_tag lookup_domains[] =
1257     {
1258       STRUCT_DOMAIN,
1259       VAR_DOMAIN,
1260       MODULE_DOMAIN
1261     };
1262     int hextype;
1263
1264     for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1265       {
1266         /* Initialize this in case we *don't* use it in this call; that
1267            way we can refer to it unconditionally below.  */
1268         memset (&is_a_field_of_this, 0, sizeof (is_a_field_of_this));
1269
1270         result = lookup_symbol (tmp, expression_context_block,
1271                                 lookup_domains[i],
1272                                 parse_language (pstate)->la_language
1273                                 == language_cplus
1274                                   ? &is_a_field_of_this : NULL);
1275         if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1276           {
1277             yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1278             return TYPENAME;
1279           }
1280
1281         if (result.symbol)
1282           break;
1283       }
1284
1285     yylval.tsym.type
1286       = language_lookup_primitive_type (parse_language (pstate),
1287                                         parse_gdbarch (pstate), tmp);
1288     if (yylval.tsym.type != NULL)
1289       return TYPENAME;
1290
1291     /* Input names that aren't symbols but ARE valid hex numbers,
1292        when the input radix permits them, can be names or numbers
1293        depending on the parse.  Note we support radixes > 16 here.  */
1294     if (!result.symbol
1295         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1296             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1297       {
1298         YYSTYPE newlval;        /* Its value is ignored.  */
1299         hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1300         if (hextype == INT)
1301           {
1302             yylval.ssym.sym = result;
1303             yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1304             return NAME_OR_INT;
1305           }
1306       }
1307
1308     /* Any other kind of symbol */
1309     yylval.ssym.sym = result;
1310     yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1311     return NAME;
1312   }
1313 }
1314
1315 int
1316 f_parse (struct parser_state *par_state)
1317 {
1318   /* Setting up the parser state.  */
1319   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1320   scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1321                                                         parser_debug);
1322   gdb_assert (par_state != NULL);
1323   pstate = par_state;
1324
1325   return yyparse ();
1326 }
1327
1328 static void
1329 yyerror (const char *msg)
1330 {
1331   if (prev_lexptr)
1332     lexptr = prev_lexptr;
1333
1334   error (_("A %s in expression, near `%s'."), msg, lexptr);
1335 }