gdb/f-exp.y

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