gdb/f-exp.y

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