gdb/f-exp.y

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