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