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