gdb/f-exp.y

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