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