gdb/f-exp.y

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