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         |       direct_abs_decl func_mod
 574                         { push_type (tp_function); }
 575         |       func_mod
 576                         { push_type (tp_function); }
 577         ;
 578
 579 func_mod:       '(' ')'
 580                         { $$ = 0; }
 581         |       '(' nonempty_typelist ')'
 582                         { free ($2); $$ = 0; }
 583         ;
 584
 585 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 586         :       TYPENAME
 587                         { $$ = $1.type; }
 588         |       INT_KEYWORD
 589                         { $$ = parse_f_type (pstate)->builtin_integer; }
 590         |       INT_S2_KEYWORD
 591                         { $$ = parse_f_type (pstate)->builtin_integer_s2; }
 592         |       CHARACTER
 593                         { $$ = parse_f_type (pstate)->builtin_character; }
 594         |       LOGICAL_S8_KEYWORD
 595                         { $$ = parse_f_type (pstate)->builtin_logical_s8; }
 596         |       LOGICAL_KEYWORD
 597                         { $$ = parse_f_type (pstate)->builtin_logical; }
 598         |       LOGICAL_S2_KEYWORD
 599                         { $$ = parse_f_type (pstate)->builtin_logical_s2; }
 600         |       LOGICAL_S1_KEYWORD
 601                         { $$ = parse_f_type (pstate)->builtin_logical_s1; }
 602         |       REAL_KEYWORD
 603                         { $$ = parse_f_type (pstate)->builtin_real; }
 604         |       REAL_S8_KEYWORD
 605                         { $$ = parse_f_type (pstate)->builtin_real_s8; }
 606         |       REAL_S16_KEYWORD
 607                         { $$ = parse_f_type (pstate)->builtin_real_s16; }
 608         |       COMPLEX_S8_KEYWORD
 609                         { $$ = parse_f_type (pstate)->builtin_complex_s8; }
 610         |       COMPLEX_S16_KEYWORD
 611                         { $$ = parse_f_type (pstate)->builtin_complex_s16; }
 612         |       COMPLEX_S32_KEYWORD
 613                         { $$ = parse_f_type (pstate)->builtin_complex_s32; }
 614         ;
 615
 616 nonempty_typelist
 617         :       type
 618                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 619                   $<ivec>$[0] = 1;      /* Number of types in vector */
 620                   $$[1] = $1;
 621                 }
 622         |       nonempty_typelist ',' type
 623                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 624                   $$ = (struct type **) realloc ((char *) $1, len);
 625                   $$[$<ivec>$[0]] = $3;
 626                 }
 627         ;
 628
 629 name    :       NAME
 630                 {  $$ = $1.stoken; }
 631         ;
 632
 633 name_not_typename :     NAME
 634 /* These would be useful if name_not_typename was useful, but it is just
 635    a fake for "variable", so these cause reduce/reduce conflicts because
 636    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 637    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 638    context where only a name could occur, this might be useful.
 639         |       NAME_OR_INT
 640    */
 641         ;
 642
 643 %%
 644
 645 /* Take care of parsing a number (anything that starts with a digit).
 646    Set yylval and return the token type; update lexptr.
 647    LEN is the number of characters in it.  */
 648
 649 /*** Needs some error checking for the float case ***/
 650
 651 static int
 652 parse_number (struct parser_state *par_state,
 653               const char *p, int len, int parsed_float, YYSTYPE *putithere)
 654 {
 655   LONGEST n = 0;
 656   LONGEST prevn = 0;
 657   int c;
 658   int base = input_radix;
 659   int unsigned_p = 0;
 660   int long_p = 0;
 661   ULONGEST high_bit;
 662   struct type *signed_type;
 663   struct type *unsigned_type;
 664
 665   if (parsed_float)
 666     {
 667       /* It's a float since it contains a point or an exponent.  */
 668       /* [dD] is not understood as an exponent by parse_float,
 669          change it to 'e'.  */
 670       char *tmp, *tmp2;
 671
 672       tmp = xstrdup (p);
 673       for (tmp2 = tmp; *tmp2; ++tmp2)
 674         if (*tmp2 == 'd' || *tmp2 == 'D')
 675           *tmp2 = 'e';
 676
 677       /* FIXME: Should this use different types?  */
 678       putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
 679       bool parsed = parse_float (tmp, len,
 680                                  putithere->typed_val_float.type,
 681                                  putithere->typed_val_float.val);
 682       free (tmp);
 683       return parsed? FLOAT : ERROR;
 684     }
 685
 686   /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
 687   if (p[0] == '0')
 688     switch (p[1])
 689       {
 690       case 'x':
 691       case 'X':
 692         if (len >= 3)
 693           {
 694             p += 2;
 695             base = 16;
 696             len -= 2;
 697           }
 698         break;
 699
 700       case 't':
 701       case 'T':
 702       case 'd':
 703       case 'D':
 704         if (len >= 3)
 705           {
 706             p += 2;
 707             base = 10;
 708             len -= 2;
 709           }
 710         break;
 711
 712       default:
 713         base = 8;
 714         break;
 715       }
 716
 717   while (len-- > 0)
 718     {
 719       c = *p++;
 720       if (isupper (c))
 721         c = tolower (c);
 722       if (len == 0 && c == 'l')
 723         long_p = 1;
 724       else if (len == 0 && c == 'u')
 725         unsigned_p = 1;
 726       else
 727         {
 728           int i;
 729           if (c >= '0' && c <= '9')
 730             i = c - '0';
 731           else if (c >= 'a' && c <= 'f')
 732             i = c - 'a' + 10;
 733           else
 734             return ERROR;       /* Char not a digit */
 735           if (i >= base)
 736             return ERROR;               /* Invalid digit in this base */
 737           n *= base;
 738           n += i;
 739         }
 740       /* Portably test for overflow (only works for nonzero values, so make
 741          a second check for zero).  */
 742       if ((prevn >= n) && n != 0)
 743         unsigned_p=1;           /* Try something unsigned */
 744       /* If range checking enabled, portably test for unsigned overflow.  */
 745       if (RANGE_CHECK && n != 0)
 746         {
 747           if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
 748             range_error (_("Overflow on numeric constant."));
 749         }
 750       prevn = n;
 751     }
 752
 753   /* If the number is too big to be an int, or it's got an l suffix
 754      then it's a long.  Work out if this has to be a long by
 755      shifting right and seeing if anything remains, and the
 756      target int size is different to the target long size.
 757
 758      In the expression below, we could have tested
 759      (n >> gdbarch_int_bit (parse_gdbarch))
 760      to see if it was zero,
 761      but too many compilers warn about that, when ints and longs
 762      are the same size.  So we shift it twice, with fewer bits
 763      each time, for the same result.  */
 764
 765   if ((gdbarch_int_bit (parse_gdbarch (par_state))
 766        != gdbarch_long_bit (parse_gdbarch (par_state))
 767        && ((n >> 2)
 768            >> (gdbarch_int_bit (parse_gdbarch (par_state))-2))) /* Avoid
 769                                                             shift warning */
 770       || long_p)
 771     {
 772       high_bit = ((ULONGEST)1)
 773       << (gdbarch_long_bit (parse_gdbarch (par_state))-1);
 774       unsigned_type = parse_type (par_state)->builtin_unsigned_long;
 775       signed_type = parse_type (par_state)->builtin_long;
 776     }
 777   else
 778     {
 779       high_bit =
 780         ((ULONGEST)1) << (gdbarch_int_bit (parse_gdbarch (par_state)) - 1);
 781       unsigned_type = parse_type (par_state)->builtin_unsigned_int;
 782       signed_type = parse_type (par_state)->builtin_int;
 783     }
 784
 785   putithere->typed_val.val = n;
 786
 787   /* If the high bit of the worked out type is set then this number
 788      has to be unsigned.  */
 789
 790   if (unsigned_p || (n & high_bit))
 791     putithere->typed_val.type = unsigned_type;
 792   else
 793     putithere->typed_val.type = signed_type;
 794
 795   return INT;
 796 }
 797
 798 /* Called to setup the type stack when we encounter a '(kind=N)' type
 799    modifier, performs some bounds checking on 'N' and then pushes this to
 800    the type stack followed by the 'tp_kind' marker.  */
 801 static void
 802 push_kind_type (LONGEST val, struct type *type)
 803 {
 804   int ival;
 805
 806   if (TYPE_UNSIGNED (type))
 807     {
 808       ULONGEST uval = static_cast <ULONGEST> (val);
 809       if (uval > INT_MAX)
 810         error (_("kind value out of range"));
 811       ival = static_cast <int> (uval);
 812     }
 813   else
 814     {
 815       if (val > INT_MAX || val < 0)
 816         error (_("kind value out of range"));
 817       ival = static_cast <int> (val);
 818     }
 819
 820   push_type_int (ival);
 821   push_type (tp_kind);
 822 }
 823
 824 /* Called when a type has a '(kind=N)' modifier after it, for example
 825    'character(kind=1)'.  The BASETYPE is the type described by 'character'
 826    in our example, and KIND is the integer '1'.  This function returns a
 827    new type that represents the basetype of a specific kind.  */
 828 static struct type *
 829 convert_to_kind_type (struct type *basetype, int kind)
 830 {
 831   if (basetype == parse_f_type (pstate)->builtin_character)
 832     {
 833       /* Character of kind 1 is a special case, this is the same as the
 834          base character type.  */
 835       if (kind == 1)
 836         return parse_f_type (pstate)->builtin_character;
 837     }
 838   else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
 839     {
 840       if (kind == 4)
 841         return parse_f_type (pstate)->builtin_complex_s8;
 842       else if (kind == 8)
 843         return parse_f_type (pstate)->builtin_complex_s16;
 844       else if (kind == 16)
 845         return parse_f_type (pstate)->builtin_complex_s32;
 846     }
 847   else if (basetype == parse_f_type (pstate)->builtin_real)
 848     {
 849       if (kind == 4)
 850         return parse_f_type (pstate)->builtin_real;
 851       else if (kind == 8)
 852         return parse_f_type (pstate)->builtin_real_s8;
 853       else if (kind == 16)
 854         return parse_f_type (pstate)->builtin_real_s16;
 855     }
 856   else if (basetype == parse_f_type (pstate)->builtin_logical)
 857     {
 858       if (kind == 1)
 859         return parse_f_type (pstate)->builtin_logical_s1;
 860       else if (kind == 2)
 861         return parse_f_type (pstate)->builtin_logical_s2;
 862       else if (kind == 4)
 863         return parse_f_type (pstate)->builtin_logical;
 864       else if (kind == 8)
 865         return parse_f_type (pstate)->builtin_logical_s8;
 866     }
 867   else if (basetype == parse_f_type (pstate)->builtin_integer)
 868     {
 869       if (kind == 2)
 870         return parse_f_type (pstate)->builtin_integer_s2;
 871       else if (kind == 4)
 872         return parse_f_type (pstate)->builtin_integer;
 873       else if (kind == 8)
 874         return parse_f_type (pstate)->builtin_integer_s8;
 875     }
 876
 877   error (_("unsupported kind %d for type %s"),
 878          kind, TYPE_SAFE_NAME (basetype));
 879
 880   /* Should never get here.  */
 881   return nullptr;
 882 }
 883
 884 struct token
 885 {
 886   /* The string to match against.  */
 887   const char *oper;
 888
 889   /* The lexer token to return.  */
 890   int token;
 891
 892   /* The expression opcode to embed within the token.  */
 893   enum exp_opcode opcode;
 894
 895   /* When this is true the string in OPER is matched exactly including
 896      case, when this is false OPER is matched case insensitively.  */
 897   bool case_sensitive;
 898 };
 899
 900 static const struct token dot_ops[] =
 901 {
 902   { ".and.", BOOL_AND, BINOP_END, false },
 903   { ".or.", BOOL_OR, BINOP_END, false },
 904   { ".not.", BOOL_NOT, BINOP_END, false },
 905   { ".eq.", EQUAL, BINOP_END, false },
 906   { ".eqv.", EQUAL, BINOP_END, false },
 907   { ".neqv.", NOTEQUAL, BINOP_END, false },
 908   { ".ne.", NOTEQUAL, BINOP_END, false },
 909   { ".le.", LEQ, BINOP_END, false },
 910   { ".ge.", GEQ, BINOP_END, false },
 911   { ".gt.", GREATERTHAN, BINOP_END, false },
 912   { ".lt.", LESSTHAN, BINOP_END, false },
 913 };
 914
 915 /* Holds the Fortran representation of a boolean, and the integer value we
 916    substitute in when one of the matching strings is parsed.  */
 917 struct f77_boolean_val
 918 {
 919   /* The string representing a Fortran boolean.  */
 920   const char *name;
 921
 922   /* The integer value to replace it with.  */
 923   int value;
 924 };
 925
 926 /* The set of Fortran booleans.  These are matched case insensitively.  */
 927 static const struct f77_boolean_val boolean_values[]  =
 928 {
 929   { ".true.", 1 },
 930   { ".false.", 0 }
 931 };
 932
 933 static const struct token f77_keywords[] =
 934 {
 935   /* Historically these have always been lowercase only in GDB.  */
 936   { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END, true },
 937   { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END, true },
 938   { "character", CHARACTER, BINOP_END, true },
 939   { "integer_2", INT_S2_KEYWORD, BINOP_END, true },
 940   { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END, true },
 941   { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END, true },
 942   { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END, true },
 943   { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END, true },
 944   { "integer", INT_KEYWORD, BINOP_END, true },
 945   { "logical", LOGICAL_KEYWORD, BINOP_END, true },
 946   { "real_16", REAL_S16_KEYWORD, BINOP_END, true },
 947   { "complex", COMPLEX_S8_KEYWORD, BINOP_END, true },
 948   { "sizeof", SIZEOF, BINOP_END, true },
 949   { "real_8", REAL_S8_KEYWORD, BINOP_END, true },
 950   { "real", REAL_KEYWORD, BINOP_END, true },
 951   /* The following correspond to actual functions in Fortran and are case
 952      insensitive.  */
 953   { "kind", KIND, BINOP_END, false },
 954   { "abs", UNOP_INTRINSIC, UNOP_ABS, false }
 955 };
 956
 957 /* Implementation of a dynamically expandable buffer for processing input
 958    characters acquired through lexptr and building a value to return in
 959    yylval.  Ripped off from ch-exp.y */
 960
 961 static char *tempbuf;           /* Current buffer contents */
 962 static int tempbufsize;         /* Size of allocated buffer */
 963 static int tempbufindex;        /* Current index into buffer */
 964
 965 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
 966
 967 #define CHECKBUF(size) \
 968   do { \
 969     if (tempbufindex + (size) >= tempbufsize) \
 970       { \
 971         growbuf_by_size (size); \
 972       } \
 973   } while (0);
 974
 975
 976 /* Grow the static temp buffer if necessary, including allocating the
 977    first one on demand.  */
 978
 979 static void
 980 growbuf_by_size (int count)
 981 {
 982   int growby;
 983
 984   growby = std::max (count, GROWBY_MIN_SIZE);
 985   tempbufsize += growby;
 986   if (tempbuf == NULL)
 987     tempbuf = (char *) malloc (tempbufsize);
 988   else
 989     tempbuf = (char *) realloc (tempbuf, tempbufsize);
 990 }
 991
 992 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
 993    string-literals.
 994
 995    Recognize a string literal.  A string literal is a nonzero sequence
 996    of characters enclosed in matching single quotes, except that
 997    a single character inside single quotes is a character literal, which
 998    we reject as a string literal.  To embed the terminator character inside
 999    a string, it is simply doubled (I.E. 'this''is''one''string') */
1000
1001 static int
1002 match_string_literal (void)
1003 {
1004   const char *tokptr = lexptr;
1005
1006   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1007     {
1008       CHECKBUF (1);
1009       if (*tokptr == *lexptr)
1010         {
1011           if (*(tokptr + 1) == *lexptr)
1012             tokptr++;
1013           else
1014             break;
1015         }
1016       tempbuf[tempbufindex++] = *tokptr;
1017     }
1018   if (*tokptr == '\0'                                   /* no terminator */
1019       || tempbufindex == 0)                             /* no string */
1020     return 0;
1021   else
1022     {
1023       tempbuf[tempbufindex] = '\0';
1024       yylval.sval.ptr = tempbuf;
1025       yylval.sval.length = tempbufindex;
1026       lexptr = ++tokptr;
1027       return STRING_LITERAL;
1028     }
1029 }
1030
1031 /* Read one token, getting characters through lexptr.  */
1032
1033 static int
1034 yylex (void)
1035 {
1036   int c;
1037   int namelen;
1038   unsigned int token;
1039   const char *tokstart;
1040
1041  retry:
1042
1043   prev_lexptr = lexptr;
1044
1045   tokstart = lexptr;
1046
1047   /* First of all, let us make sure we are not dealing with the
1048      special tokens .true. and .false. which evaluate to 1 and 0.  */
1049
1050   if (*lexptr == '.')
1051     {
1052       for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1053         {
1054           if (strncasecmp (tokstart, boolean_values[i].name,
1055                            strlen (boolean_values[i].name)) == 0)
1056             {
1057               lexptr += strlen (boolean_values[i].name);
1058               yylval.lval = boolean_values[i].value;
1059               return BOOLEAN_LITERAL;
1060             }
1061         }
1062     }
1063
1064   /* See if it is a special .foo. operator.  */
1065   for (int i = 0; i < ARRAY_SIZE (dot_ops); i++)
1066     if (strncasecmp (tokstart, dot_ops[i].oper,
1067                      strlen (dot_ops[i].oper)) == 0)
1068       {
1069         gdb_assert (!dot_ops[i].case_sensitive);
1070         lexptr += strlen (dot_ops[i].oper);
1071         yylval.opcode = dot_ops[i].opcode;
1072         return dot_ops[i].token;
1073       }
1074
1075   /* See if it is an exponentiation operator.  */
1076
1077   if (strncmp (tokstart, "**", 2) == 0)
1078     {
1079       lexptr += 2;
1080       yylval.opcode = BINOP_EXP;
1081       return STARSTAR;
1082     }
1083
1084   switch (c = *tokstart)
1085     {
1086     case 0:
1087       return 0;
1088
1089     case ' ':
1090     case '\t':
1091     case '\n':
1092       lexptr++;
1093       goto retry;
1094
1095     case '\'':
1096       token = match_string_literal ();
1097       if (token != 0)
1098         return (token);
1099       break;
1100
1101     case '(':
1102       paren_depth++;
1103       lexptr++;
1104       return c;
1105
1106     case ')':
1107       if (paren_depth == 0)
1108         return 0;
1109       paren_depth--;
1110       lexptr++;
1111       return c;
1112
1113     case ',':
1114       if (comma_terminates && paren_depth == 0)
1115         return 0;
1116       lexptr++;
1117       return c;
1118
1119     case '.':
1120       /* Might be a floating point number.  */
1121       if (lexptr[1] < '0' || lexptr[1] > '9')
1122         goto symbol;            /* Nope, must be a symbol.  */
1123       /* FALL THRU.  */
1124
1125     case '0':
1126     case '1':
1127     case '2':
1128     case '3':
1129     case '4':
1130     case '5':
1131     case '6':
1132     case '7':
1133     case '8':
1134     case '9':
1135       {
1136         /* It's a number.  */
1137         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1138         const char *p = tokstart;
1139         int hex = input_radix > 10;
1140
1141         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1142           {
1143             p += 2;
1144             hex = 1;
1145           }
1146         else if (c == '0' && (p[1]=='t' || p[1]=='T'
1147                               || p[1]=='d' || p[1]=='D'))
1148           {
1149             p += 2;
1150             hex = 0;
1151           }
1152
1153         for (;; ++p)
1154           {
1155             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1156               got_dot = got_e = 1;
1157             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1158               got_dot = got_d = 1;
1159             else if (!hex && !got_dot && *p == '.')
1160               got_dot = 1;
1161             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1162                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1163                      && (*p == '-' || *p == '+'))
1164               /* This is the sign of the exponent, not the end of the
1165                  number.  */
1166               continue;
1167             /* We will take any letters or digits.  parse_number will
1168                complain if past the radix, or if L or U are not final.  */
1169             else if ((*p < '0' || *p > '9')
1170                      && ((*p < 'a' || *p > 'z')
1171                          && (*p < 'A' || *p > 'Z')))
1172               break;
1173           }
1174         toktype = parse_number (pstate, tokstart, p - tokstart,
1175                                 got_dot|got_e|got_d,
1176                                 &yylval);
1177         if (toktype == ERROR)
1178           {
1179             char *err_copy = (char *) alloca (p - tokstart + 1);
1180
1181             memcpy (err_copy, tokstart, p - tokstart);
1182             err_copy[p - tokstart] = 0;
1183             error (_("Invalid number \"%s\"."), err_copy);
1184           }
1185         lexptr = p;
1186         return toktype;
1187       }
1188
1189     case '+':
1190     case '-':
1191     case '*':
1192     case '/':
1193     case '%':
1194     case '|':
1195     case '&':
1196     case '^':
1197     case '~':
1198     case '!':
1199     case '@':
1200     case '<':
1201     case '>':
1202     case '[':
1203     case ']':
1204     case '?':
1205     case ':':
1206     case '=':
1207     case '{':
1208     case '}':
1209     symbol:
1210       lexptr++;
1211       return c;
1212     }
1213
1214   if (!(c == '_' || c == '$' || c ==':'
1215         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1216     /* We must have come across a bad character (e.g. ';').  */
1217     error (_("Invalid character '%c' in expression."), c);
1218
1219   namelen = 0;
1220   for (c = tokstart[namelen];
1221        (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1222         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1223        c = tokstart[++namelen]);
1224
1225   /* The token "if" terminates the expression and is NOT
1226      removed from the input stream.  */
1227
1228   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1229     return 0;
1230
1231   lexptr += namelen;
1232
1233   /* Catch specific keywords.  */
1234
1235   for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1236     if (strlen (f77_keywords[i].oper) == namelen
1237         && ((!f77_keywords[i].case_sensitive
1238              && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1239             || (f77_keywords[i].case_sensitive
1240                 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1241       {
1242         yylval.opcode = f77_keywords[i].opcode;
1243         return f77_keywords[i].token;
1244       }
1245
1246   yylval.sval.ptr = tokstart;
1247   yylval.sval.length = namelen;
1248
1249   if (*tokstart == '$')
1250     {
1251       write_dollar_variable (pstate, yylval.sval);
1252       return DOLLAR_VARIABLE;
1253     }
1254
1255   /* Use token-type TYPENAME for symbols that happen to be defined
1256      currently as names of types; NAME for other symbols.
1257      The caller is not constrained to care about the distinction.  */
1258   {
1259     char *tmp = copy_name (yylval.sval);
1260     struct block_symbol result;
1261     struct field_of_this_result is_a_field_of_this;
1262     enum domain_enum_tag lookup_domains[] =
1263     {
1264       STRUCT_DOMAIN,
1265       VAR_DOMAIN,
1266       MODULE_DOMAIN
1267     };
1268     int hextype;
1269
1270     for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1271       {
1272         /* Initialize this in case we *don't* use it in this call; that
1273            way we can refer to it unconditionally below.  */
1274         memset (&is_a_field_of_this, 0, sizeof (is_a_field_of_this));
1275
1276         result = lookup_symbol (tmp, expression_context_block,
1277                                 lookup_domains[i],
1278                                 parse_language (pstate)->la_language
1279                                 == language_cplus
1280                                   ? &is_a_field_of_this : NULL);
1281         if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1282           {
1283             yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1284             return TYPENAME;
1285           }
1286
1287         if (result.symbol)
1288           break;
1289       }
1290
1291     yylval.tsym.type
1292       = language_lookup_primitive_type (parse_language (pstate),
1293                                         parse_gdbarch (pstate), tmp);
1294     if (yylval.tsym.type != NULL)
1295       return TYPENAME;
1296
1297     /* Input names that aren't symbols but ARE valid hex numbers,
1298        when the input radix permits them, can be names or numbers
1299        depending on the parse.  Note we support radixes > 16 here.  */
1300     if (!result.symbol
1301         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1302             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1303       {
1304         YYSTYPE newlval;        /* Its value is ignored.  */
1305         hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1306         if (hextype == INT)
1307           {
1308             yylval.ssym.sym = result;
1309             yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1310             return NAME_OR_INT;
1311           }
1312       }
1313
1314     /* Any other kind of symbol */
1315     yylval.ssym.sym = result;
1316     yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1317     return NAME;
1318   }
1319 }
1320
1321 int
1322 f_parse (struct parser_state *par_state)
1323 {
1324   /* Setting up the parser state.  */
1325   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1326   scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1327                                                         parser_debug);
1328   gdb_assert (par_state != NULL);
1329   pstate = par_state;
1330
1331   return yyparse ();
1332 }
1333
1334 static void
1335 yyerror (const char *msg)
1336 {
1337   if (prev_lexptr)
1338     lexptr = prev_lexptr;
1339
1340   error (_("A %s in expression, near `%s'."), msg, lexptr);
1341 }