gdb/f-exp.y

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