gdb/f-exp.y

   1 /* YACC parser for Fortran expressions, for GDB.
   2    Copyright (C) 1986, 1989, 1990, 1991, 1993, 1994, 1995, 1996, 2000, 2001,
   3    2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4    Free Software Foundation, Inc.
   5
   6    Contributed by Motorola.  Adapted from the C parser by Farooq Butt
   7    (fmbutt@engage.sps.mot.com).
   8
   9    This file is part of GDB.
  10
  11    This program is free software; you can redistribute it and/or modify
  12    it under the terms of the GNU General Public License as published by
  13    the Free Software Foundation; either version 3 of the License, or
  14    (at your option) any later version.
  15
  16    This program is distributed in the hope that it will be useful,
  17    but WITHOUT ANY WARRANTY; without even the implied warranty of
  18    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19    GNU General Public License for more details.
  20
  21    You should have received a copy of the GNU General Public License
  22    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  23
  24 /* This was blantantly ripped off the C expression parser, please
  25    be aware of that as you look at its basic structure -FMB */
  26
  27 /* Parse a F77 expression from text in a string,
  28    and return the result as a  struct expression  pointer.
  29    That structure contains arithmetic operations in reverse polish,
  30    with constants represented by operations that are followed by special data.
  31    See expression.h for the details of the format.
  32    What is important here is that it can be built up sequentially
  33    during the process of parsing; the lower levels of the tree always
  34    come first in the result.
  35
  36    Note that malloc's and realloc's in this file are transformed to
  37    xmalloc and xrealloc respectively by the same sed command in the
  38    makefile that remaps any other malloc/realloc inserted by the parser
  39    generator.  Doing this with #defines and trying to control the interaction
  40    with include files (<malloc.h> and <stdlib.h> for example) just became
  41    too messy, particularly when such includes can be inserted at random
  42    times by the parser generator.  */
  43
  44 %{
  45
  46 #include "defs.h"
  47 #include "gdb_string.h"
  48 #include "expression.h"
  49 #include "value.h"
  50 #include "parser-defs.h"
  51 #include "language.h"
  52 #include "f-lang.h"
  53 #include "bfd.h" /* Required by objfiles.h.  */
  54 #include "symfile.h" /* Required by objfiles.h.  */
  55 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
  56 #include "block.h"
  57 #include <ctype.h>
  58
  59 #define parse_type builtin_type (parse_gdbarch)
  60 #define parse_f_type builtin_f_type (parse_gdbarch)
  61
  62 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
  63    as well as gratuitiously global symbol names, so we can have multiple
  64    yacc generated parsers in gdb.  Note that these are only the variables
  65    produced by yacc.  If other parser generators (bison, byacc, etc) produce
  66    additional global names that conflict at link time, then those parser
  67    generators need to be fixed instead of adding those names to this list. */
  68
  69 #define yymaxdepth f_maxdepth
  70 #define yyparse f_parse
  71 #define yylex   f_lex
  72 #define yyerror f_error
  73 #define yylval  f_lval
  74 #define yychar  f_char
  75 #define yydebug f_debug
  76 #define yypact  f_pact
  77 #define yyr1    f_r1
  78 #define yyr2    f_r2
  79 #define yydef   f_def
  80 #define yychk   f_chk
  81 #define yypgo   f_pgo
  82 #define yyact   f_act
  83 #define yyexca  f_exca
  84 #define yyerrflag f_errflag
  85 #define yynerrs f_nerrs
  86 #define yyps    f_ps
  87 #define yypv    f_pv
  88 #define yys     f_s
  89 #define yy_yys  f_yys
  90 #define yystate f_state
  91 #define yytmp   f_tmp
  92 #define yyv     f_v
  93 #define yy_yyv  f_yyv
  94 #define yyval   f_val
  95 #define yylloc  f_lloc
  96 #define yyreds  f_reds          /* With YYDEBUG defined */
  97 #define yytoks  f_toks          /* With YYDEBUG defined */
  98 #define yyname  f_name          /* With YYDEBUG defined */
  99 #define yyrule  f_rule          /* With YYDEBUG defined */
 100 #define yylhs   f_yylhs
 101 #define yylen   f_yylen
 102 #define yydefred f_yydefred
 103 #define yydgoto f_yydgoto
 104 #define yysindex f_yysindex
 105 #define yyrindex f_yyrindex
 106 #define yygindex f_yygindex
 107 #define yytable  f_yytable
 108 #define yycheck  f_yycheck
 109
 110 #ifndef YYDEBUG
 111 #define YYDEBUG 1               /* Default to yydebug support */
 112 #endif
 113
 114 #define YYFPRINTF parser_fprintf
 115
 116 int yyparse (void);
 117
 118 static int yylex (void);
 119
 120 void yyerror (char *);
 121
 122 static void growbuf_by_size (int);
 123
 124 static int match_string_literal (void);
 125
 126 %}
 127
 128 /* Although the yacc "value" of an expression is not used,
 129    since the result is stored in the structure being created,
 130    other node types do have values.  */
 131
 132 %union
 133   {
 134     LONGEST lval;
 135     struct {
 136       LONGEST val;
 137       struct type *type;
 138     } typed_val;
 139     DOUBLEST dval;
 140     struct symbol *sym;
 141     struct type *tval;
 142     struct stoken sval;
 143     struct ttype tsym;
 144     struct symtoken ssym;
 145     int voidval;
 146     struct block *bval;
 147     enum exp_opcode opcode;
 148     struct internalvar *ivar;
 149
 150     struct type **tvec;
 151     int *ivec;
 152   }
 153
 154 %{
 155 /* YYSTYPE gets defined by %union */
 156 static int parse_number (char *, int, int, YYSTYPE *);
 157 %}
 158
 159 %type <voidval> exp  type_exp start variable
 160 %type <tval> type typebase
 161 %type <tvec> nonempty_typelist
 162 /* %type <bval> block */
 163
 164 /* Fancy type parsing.  */
 165 %type <voidval> func_mod direct_abs_decl abs_decl
 166 %type <tval> ptype
 167
 168 %token <typed_val> INT
 169 %token <dval> FLOAT
 170
 171 /* Both NAME and TYPENAME tokens represent symbols in the input,
 172    and both convey their data as strings.
 173    But a TYPENAME is a string that happens to be defined as a typedef
 174    or builtin type name (such as int or char)
 175    and a NAME is any other symbol.
 176    Contexts where this distinction is not important can use the
 177    nonterminal "name", which matches either NAME or TYPENAME.  */
 178
 179 %token <sval> STRING_LITERAL
 180 %token <lval> BOOLEAN_LITERAL
 181 %token <ssym> NAME
 182 %token <tsym> TYPENAME
 183 %type <sval> name
 184 %type <ssym> name_not_typename
 185
 186 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
 187    but which would parse as a valid number in the current input radix.
 188    E.g. "c" when input_radix==16.  Depending on the parse, it will be
 189    turned into a name or into a number.  */
 190
 191 %token <ssym> NAME_OR_INT
 192
 193 %token  SIZEOF
 194 %token ERROR
 195
 196 /* Special type cases, put in to allow the parser to distinguish different
 197    legal basetypes.  */
 198 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
 199 %token LOGICAL_S8_KEYWORD
 200 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
 201 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
 202 %token BOOL_AND BOOL_OR BOOL_NOT
 203 %token <lval> CHARACTER
 204
 205 %token <voidval> VARIABLE
 206
 207 %token <opcode> ASSIGN_MODIFY
 208
 209 %left ','
 210 %left ABOVE_COMMA
 211 %right '=' ASSIGN_MODIFY
 212 %right '?'
 213 %left BOOL_OR
 214 %right BOOL_NOT
 215 %left BOOL_AND
 216 %left '|'
 217 %left '^'
 218 %left '&'
 219 %left EQUAL NOTEQUAL
 220 %left LESSTHAN GREATERTHAN LEQ GEQ
 221 %left LSH RSH
 222 %left '@'
 223 %left '+' '-'
 224 %left '*' '/'
 225 %right STARSTAR
 226 %right '%'
 227 %right UNARY
 228 %right '('
 229
 230 \f
 231 %%
 232
 233 start   :       exp
 234         |       type_exp
 235         ;
 236
 237 type_exp:       type
 238                         { write_exp_elt_opcode(OP_TYPE);
 239                           write_exp_elt_type($1);
 240                           write_exp_elt_opcode(OP_TYPE); }
 241         ;
 242
 243 exp     :       '(' exp ')'
 244                         { }
 245         ;
 246
 247 /* Expressions, not including the comma operator.  */
 248 exp     :       '*' exp    %prec UNARY
 249                         { write_exp_elt_opcode (UNOP_IND); }
 250         ;
 251
 252 exp     :       '&' exp    %prec UNARY
 253                         { write_exp_elt_opcode (UNOP_ADDR); }
 254         ;
 255
 256 exp     :       '-' exp    %prec UNARY
 257                         { write_exp_elt_opcode (UNOP_NEG); }
 258         ;
 259
 260 exp     :       BOOL_NOT exp    %prec UNARY
 261                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 262         ;
 263
 264 exp     :       '~' exp    %prec UNARY
 265                         { write_exp_elt_opcode (UNOP_COMPLEMENT); }
 266         ;
 267
 268 exp     :       SIZEOF exp       %prec UNARY
 269                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 270         ;
 271
 272 /* No more explicit array operators, we treat everything in F77 as
 273    a function call.  The disambiguation as to whether we are
 274    doing a subscript operation or a function call is done
 275    later in eval.c.  */
 276
 277 exp     :       exp '('
 278                         { start_arglist (); }
 279                 arglist ')'
 280                         { write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST);
 281                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 282                           write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); }
 283         ;
 284
 285 arglist :
 286         ;
 287
 288 arglist :       exp
 289                         { arglist_len = 1; }
 290         ;
 291
 292 arglist :       subrange
 293                         { arglist_len = 1; }
 294         ;
 295
 296 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 297                         { arglist_len++; }
 298         ;
 299
 300 /* There are four sorts of subrange types in F90.  */
 301
 302 subrange:       exp ':' exp     %prec ABOVE_COMMA
 303                         { write_exp_elt_opcode (OP_F90_RANGE);
 304                           write_exp_elt_longcst (NONE_BOUND_DEFAULT);
 305                           write_exp_elt_opcode (OP_F90_RANGE); }
 306         ;
 307
 308 subrange:       exp ':' %prec ABOVE_COMMA
 309                         { write_exp_elt_opcode (OP_F90_RANGE);
 310                           write_exp_elt_longcst (HIGH_BOUND_DEFAULT);
 311                           write_exp_elt_opcode (OP_F90_RANGE); }
 312         ;
 313
 314 subrange:       ':' exp %prec ABOVE_COMMA
 315                         { write_exp_elt_opcode (OP_F90_RANGE);
 316                           write_exp_elt_longcst (LOW_BOUND_DEFAULT);
 317                           write_exp_elt_opcode (OP_F90_RANGE); }
 318         ;
 319
 320 subrange:       ':'     %prec ABOVE_COMMA
 321                         { write_exp_elt_opcode (OP_F90_RANGE);
 322                           write_exp_elt_longcst (BOTH_BOUND_DEFAULT);
 323                           write_exp_elt_opcode (OP_F90_RANGE); }
 324         ;
 325
 326 complexnum:     exp ',' exp
 327                         { }
 328         ;
 329
 330 exp     :       '(' complexnum ')'
 331                         { write_exp_elt_opcode(OP_COMPLEX);
 332                           write_exp_elt_type (parse_f_type->builtin_complex_s16);
 333                           write_exp_elt_opcode(OP_COMPLEX); }
 334         ;
 335
 336 exp     :       '(' type ')' exp  %prec UNARY
 337                         { write_exp_elt_opcode (UNOP_CAST);
 338                           write_exp_elt_type ($2);
 339                           write_exp_elt_opcode (UNOP_CAST); }
 340         ;
 341
 342 exp     :       exp '%' name
 343                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 344                           write_exp_string ($3);
 345                           write_exp_elt_opcode (STRUCTOP_STRUCT); }
 346         ;
 347
 348 /* Binary operators in order of decreasing precedence.  */
 349
 350 exp     :       exp '@' exp
 351                         { write_exp_elt_opcode (BINOP_REPEAT); }
 352         ;
 353
 354 exp     :       exp STARSTAR exp
 355                         { write_exp_elt_opcode (BINOP_EXP); }
 356         ;
 357
 358 exp     :       exp '*' exp
 359                         { write_exp_elt_opcode (BINOP_MUL); }
 360         ;
 361
 362 exp     :       exp '/' exp
 363                         { write_exp_elt_opcode (BINOP_DIV); }
 364         ;
 365
 366 exp     :       exp '+' exp
 367                         { write_exp_elt_opcode (BINOP_ADD); }
 368         ;
 369
 370 exp     :       exp '-' exp
 371                         { write_exp_elt_opcode (BINOP_SUB); }
 372         ;
 373
 374 exp     :       exp LSH exp
 375                         { write_exp_elt_opcode (BINOP_LSH); }
 376         ;
 377
 378 exp     :       exp RSH exp
 379                         { write_exp_elt_opcode (BINOP_RSH); }
 380         ;
 381
 382 exp     :       exp EQUAL exp
 383                         { write_exp_elt_opcode (BINOP_EQUAL); }
 384         ;
 385
 386 exp     :       exp NOTEQUAL exp
 387                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 388         ;
 389
 390 exp     :       exp LEQ exp
 391                         { write_exp_elt_opcode (BINOP_LEQ); }
 392         ;
 393
 394 exp     :       exp GEQ exp
 395                         { write_exp_elt_opcode (BINOP_GEQ); }
 396         ;
 397
 398 exp     :       exp LESSTHAN exp
 399                         { write_exp_elt_opcode (BINOP_LESS); }
 400         ;
 401
 402 exp     :       exp GREATERTHAN exp
 403                         { write_exp_elt_opcode (BINOP_GTR); }
 404         ;
 405
 406 exp     :       exp '&' exp
 407                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 408         ;
 409
 410 exp     :       exp '^' exp
 411                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 412         ;
 413
 414 exp     :       exp '|' exp
 415                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 416         ;
 417
 418 exp     :       exp BOOL_AND exp
 419                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 420         ;
 421
 422
 423 exp     :       exp BOOL_OR exp
 424                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 425         ;
 426
 427 exp     :       exp '=' exp
 428                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 429         ;
 430
 431 exp     :       exp ASSIGN_MODIFY exp
 432                         { write_exp_elt_opcode (BINOP_ASSIGN_MODIFY);
 433                           write_exp_elt_opcode ($2);
 434                           write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); }
 435         ;
 436
 437 exp     :       INT
 438                         { write_exp_elt_opcode (OP_LONG);
 439                           write_exp_elt_type ($1.type);
 440                           write_exp_elt_longcst ((LONGEST)($1.val));
 441                           write_exp_elt_opcode (OP_LONG); }
 442         ;
 443
 444 exp     :       NAME_OR_INT
 445                         { YYSTYPE val;
 446                           parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val);
 447                           write_exp_elt_opcode (OP_LONG);
 448                           write_exp_elt_type (val.typed_val.type);
 449                           write_exp_elt_longcst ((LONGEST)val.typed_val.val);
 450                           write_exp_elt_opcode (OP_LONG); }
 451         ;
 452
 453 exp     :       FLOAT
 454                         { write_exp_elt_opcode (OP_DOUBLE);
 455                           write_exp_elt_type (parse_f_type->builtin_real_s8);
 456                           write_exp_elt_dblcst ($1);
 457                           write_exp_elt_opcode (OP_DOUBLE); }
 458         ;
 459
 460 exp     :       variable
 461         ;
 462
 463 exp     :       VARIABLE
 464         ;
 465
 466 exp     :       SIZEOF '(' type ')'     %prec UNARY
 467                         { write_exp_elt_opcode (OP_LONG);
 468                           write_exp_elt_type (parse_f_type->builtin_integer);
 469                           CHECK_TYPEDEF ($3);
 470                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 471                           write_exp_elt_opcode (OP_LONG); }
 472         ;
 473
 474 exp     :       BOOLEAN_LITERAL
 475                         { write_exp_elt_opcode (OP_BOOL);
 476                           write_exp_elt_longcst ((LONGEST) $1);
 477                           write_exp_elt_opcode (OP_BOOL);
 478                         }
 479         ;
 480
 481 exp     :       STRING_LITERAL
 482                         {
 483                           write_exp_elt_opcode (OP_STRING);
 484                           write_exp_string ($1);
 485                           write_exp_elt_opcode (OP_STRING);
 486                         }
 487         ;
 488
 489 variable:       name_not_typename
 490                         { struct symbol *sym = $1.sym;
 491
 492                           if (sym)
 493                             {
 494                               if (symbol_read_needs_frame (sym))
 495                                 {
 496                                   if (innermost_block == 0
 497                                       || contained_in (block_found,
 498                                                        innermost_block))
 499                                     innermost_block = block_found;
 500                                 }
 501                               write_exp_elt_opcode (OP_VAR_VALUE);
 502                               /* We want to use the selected frame, not
 503                                  another more inner frame which happens to
 504                                  be in the same block.  */
 505                               write_exp_elt_block (NULL);
 506                               write_exp_elt_sym (sym);
 507                               write_exp_elt_opcode (OP_VAR_VALUE);
 508                               break;
 509                             }
 510                           else
 511                             {
 512                               struct minimal_symbol *msymbol;
 513                               char *arg = copy_name ($1.stoken);
 514
 515                               msymbol =
 516                                 lookup_minimal_symbol (arg, NULL, NULL);
 517                               if (msymbol != NULL)
 518                                 write_exp_msymbol (msymbol);
 519                               else if (!have_full_symbols () && !have_partial_symbols ())
 520                                 error ("No symbol table is loaded.  Use the \"file\" command.");
 521                               else
 522                                 error ("No symbol \"%s\" in current context.",
 523                                        copy_name ($1.stoken));
 524                             }
 525                         }
 526         ;
 527
 528
 529 type    :       ptype
 530         ;
 531
 532 ptype   :       typebase
 533         |       typebase abs_decl
 534                 {
 535                   /* This is where the interesting stuff happens.  */
 536                   int done = 0;
 537                   int array_size;
 538                   struct type *follow_type = $1;
 539                   struct type *range_type;
 540
 541                   while (!done)
 542                     switch (pop_type ())
 543                       {
 544                       case tp_end:
 545                         done = 1;
 546                         break;
 547                       case tp_pointer:
 548                         follow_type = lookup_pointer_type (follow_type);
 549                         break;
 550                       case tp_reference:
 551                         follow_type = lookup_reference_type (follow_type);
 552                         break;
 553                       case tp_array:
 554                         array_size = pop_type_int ();
 555                         if (array_size != -1)
 556                           {
 557                             range_type =
 558                               create_range_type ((struct type *) NULL,
 559                                                  parse_f_type->builtin_integer,
 560                                                  0, array_size - 1);
 561                             follow_type =
 562                               create_array_type ((struct type *) NULL,
 563                                                  follow_type, range_type);
 564                           }
 565                         else
 566                           follow_type = lookup_pointer_type (follow_type);
 567                         break;
 568                       case tp_function:
 569                         follow_type = lookup_function_type (follow_type);
 570                         break;
 571                       }
 572                   $$ = follow_type;
 573                 }
 574         ;
 575
 576 abs_decl:       '*'
 577                         { push_type (tp_pointer); $$ = 0; }
 578         |       '*' abs_decl
 579                         { push_type (tp_pointer); $$ = $2; }
 580         |       '&'
 581                         { push_type (tp_reference); $$ = 0; }
 582         |       '&' abs_decl
 583                         { push_type (tp_reference); $$ = $2; }
 584         |       direct_abs_decl
 585         ;
 586
 587 direct_abs_decl: '(' abs_decl ')'
 588                         { $$ = $2; }
 589         |       direct_abs_decl func_mod
 590                         { push_type (tp_function); }
 591         |       func_mod
 592                         { push_type (tp_function); }
 593         ;
 594
 595 func_mod:       '(' ')'
 596                         { $$ = 0; }
 597         |       '(' nonempty_typelist ')'
 598                         { free ($2); $$ = 0; }
 599         ;
 600
 601 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 602         :       TYPENAME
 603                         { $$ = $1.type; }
 604         |       INT_KEYWORD
 605                         { $$ = parse_f_type->builtin_integer; }
 606         |       INT_S2_KEYWORD
 607                         { $$ = parse_f_type->builtin_integer_s2; }
 608         |       CHARACTER
 609                         { $$ = parse_f_type->builtin_character; }
 610         |       LOGICAL_S8_KEYWORD
 611                         { $$ = parse_f_type->builtin_logical_s8; }
 612         |       LOGICAL_KEYWORD
 613                         { $$ = parse_f_type->builtin_logical; }
 614         |       LOGICAL_S2_KEYWORD
 615                         { $$ = parse_f_type->builtin_logical_s2; }
 616         |       LOGICAL_S1_KEYWORD
 617                         { $$ = parse_f_type->builtin_logical_s1; }
 618         |       REAL_KEYWORD
 619                         { $$ = parse_f_type->builtin_real; }
 620         |       REAL_S8_KEYWORD
 621                         { $$ = parse_f_type->builtin_real_s8; }
 622         |       REAL_S16_KEYWORD
 623                         { $$ = parse_f_type->builtin_real_s16; }
 624         |       COMPLEX_S8_KEYWORD
 625                         { $$ = parse_f_type->builtin_complex_s8; }
 626         |       COMPLEX_S16_KEYWORD
 627                         { $$ = parse_f_type->builtin_complex_s16; }
 628         |       COMPLEX_S32_KEYWORD
 629                         { $$ = parse_f_type->builtin_complex_s32; }
 630         ;
 631
 632 nonempty_typelist
 633         :       type
 634                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 635                   $<ivec>$[0] = 1;      /* Number of types in vector */
 636                   $$[1] = $1;
 637                 }
 638         |       nonempty_typelist ',' type
 639                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 640                   $$ = (struct type **) realloc ((char *) $1, len);
 641                   $$[$<ivec>$[0]] = $3;
 642                 }
 643         ;
 644
 645 name    :       NAME
 646                 {  $$ = $1.stoken; }
 647         ;
 648
 649 name_not_typename :     NAME
 650 /* These would be useful if name_not_typename was useful, but it is just
 651    a fake for "variable", so these cause reduce/reduce conflicts because
 652    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 653    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 654    context where only a name could occur, this might be useful.
 655         |       NAME_OR_INT
 656    */
 657         ;
 658
 659 %%
 660
 661 /* Take care of parsing a number (anything that starts with a digit).
 662    Set yylval and return the token type; update lexptr.
 663    LEN is the number of characters in it.  */
 664
 665 /*** Needs some error checking for the float case ***/
 666
 667 static int
 668 parse_number (p, len, parsed_float, putithere)
 669      char *p;
 670      int len;
 671      int parsed_float;
 672      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 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 first one
 896    on demand. */
 897
 898 static void
 899 growbuf_by_size (count)
 900      int count;
 901 {
 902   int growby;
 903
 904   growby = max (count, GROWBY_MIN_SIZE);
 905   tempbufsize += growby;
 906   if (tempbuf == NULL)
 907     tempbuf = (char *) malloc (tempbufsize);
 908   else
 909     tempbuf = (char *) realloc (tempbuf, tempbufsize);
 910 }
 911
 912 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
 913    string-literals.
 914
 915    Recognize a string literal.  A string literal is a nonzero sequence
 916    of characters enclosed in matching single quotes, except that
 917    a single character inside single quotes is a character literal, which
 918    we reject as a string literal.  To embed the terminator character inside
 919    a string, it is simply doubled (I.E. 'this''is''one''string') */
 920
 921 static int
 922 match_string_literal ()
 923 {
 924   char *tokptr = lexptr;
 925
 926   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
 927     {
 928       CHECKBUF (1);
 929       if (*tokptr == *lexptr)
 930         {
 931           if (*(tokptr + 1) == *lexptr)
 932             tokptr++;
 933           else
 934             break;
 935         }
 936       tempbuf[tempbufindex++] = *tokptr;
 937     }
 938   if (*tokptr == '\0'                                   /* no terminator */
 939       || tempbufindex == 0)                             /* no string */
 940     return 0;
 941   else
 942     {
 943       tempbuf[tempbufindex] = '\0';
 944       yylval.sval.ptr = tempbuf;
 945       yylval.sval.length = tempbufindex;
 946       lexptr = ++tokptr;
 947       return STRING_LITERAL;
 948     }
 949 }
 950
 951 /* Read one token, getting characters through lexptr.  */
 952
 953 static int
 954 yylex ()
 955 {
 956   int c;
 957   int namelen;
 958   unsigned int i,token;
 959   char *tokstart;
 960
 961  retry:
 962
 963   prev_lexptr = lexptr;
 964
 965   tokstart = lexptr;
 966
 967   /* First of all, let us make sure we are not dealing with the
 968      special tokens .true. and .false. which evaluate to 1 and 0.  */
 969
 970   if (*lexptr == '.')
 971     {
 972       for (i = 0; boolean_values[i].name != NULL; i++)
 973         {
 974           if (strncmp (tokstart, boolean_values[i].name,
 975                        strlen (boolean_values[i].name)) == 0)
 976             {
 977               lexptr += strlen (boolean_values[i].name);
 978               yylval.lval = boolean_values[i].value;
 979               return BOOLEAN_LITERAL;
 980             }
 981         }
 982     }
 983
 984   /* See if it is a special .foo. operator.  */
 985
 986   for (i = 0; dot_ops[i].operator != NULL; i++)
 987     if (strncmp (tokstart, dot_ops[i].operator, 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         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' || p[1]=='d' || p[1]=='D'))
1066           {
1067             p += 2;
1068             hex = 0;
1069           }
1070
1071         for (;; ++p)
1072           {
1073             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1074               got_dot = got_e = 1;
1075             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1076               got_dot = got_d = 1;
1077             else if (!hex && !got_dot && *p == '.')
1078               got_dot = 1;
1079             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1080                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1081                      && (*p == '-' || *p == '+'))
1082               /* This is the sign of the exponent, not the end of the
1083                  number.  */
1084               continue;
1085             /* We will take any letters or digits.  parse_number will
1086                complain if past the radix, or if L or U are not final.  */
1087             else if ((*p < '0' || *p > '9')
1088                      && ((*p < 'a' || *p > 'z')
1089                          && (*p < 'A' || *p > 'Z')))
1090               break;
1091           }
1092         toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d,
1093                                 &yylval);
1094         if (toktype == ERROR)
1095           {
1096             char *err_copy = (char *) alloca (p - tokstart + 1);
1097
1098             memcpy (err_copy, tokstart, p - tokstart);
1099             err_copy[p - tokstart] = 0;
1100             error ("Invalid number \"%s\".", err_copy);
1101           }
1102         lexptr = p;
1103         return toktype;
1104       }
1105
1106     case '+':
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     symbol:
1127       lexptr++;
1128       return c;
1129     }
1130
1131   if (!(c == '_' || c == '$' || c ==':'
1132         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1133     /* We must have come across a bad character (e.g. ';').  */
1134     error ("Invalid character '%c' in expression.", c);
1135
1136   namelen = 0;
1137   for (c = tokstart[namelen];
1138        (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1139         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1140        c = tokstart[++namelen]);
1141
1142   /* The token "if" terminates the expression and is NOT
1143      removed from the input stream.  */
1144
1145   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1146     return 0;
1147
1148   lexptr += namelen;
1149
1150   /* Catch specific keywords.  */
1151
1152   for (i = 0; f77_keywords[i].operator != NULL; i++)
1153     if (strncmp (tokstart, f77_keywords[i].operator,
1154                  strlen(f77_keywords[i].operator)) == 0)
1155       {
1156         /*      lexptr += strlen(f77_keywords[i].operator); */
1157         yylval.opcode = f77_keywords[i].opcode;
1158         return f77_keywords[i].token;
1159       }
1160
1161   yylval.sval.ptr = tokstart;
1162   yylval.sval.length = namelen;
1163
1164   if (*tokstart == '$')
1165     {
1166       write_dollar_variable (yylval.sval);
1167       return VARIABLE;
1168     }
1169
1170   /* Use token-type TYPENAME for symbols that happen to be defined
1171      currently as names of types; NAME for other symbols.
1172      The caller is not constrained to care about the distinction.  */
1173   {
1174     char *tmp = copy_name (yylval.sval);
1175     struct symbol *sym;
1176     int is_a_field_of_this = 0;
1177     int hextype;
1178
1179     sym = lookup_symbol (tmp, expression_context_block,
1180                          VAR_DOMAIN,
1181                          parse_language->la_language == language_cplus
1182                          ? &is_a_field_of_this : NULL);
1183     if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1184       {
1185         yylval.tsym.type = SYMBOL_TYPE (sym);
1186         return TYPENAME;
1187       }
1188     yylval.tsym.type
1189       = language_lookup_primitive_type_by_name (parse_language,
1190                                                 parse_gdbarch, tmp);
1191     if (yylval.tsym.type != NULL)
1192       return TYPENAME;
1193
1194     /* Input names that aren't symbols but ARE valid hex numbers,
1195        when the input radix permits them, can be names or numbers
1196        depending on the parse.  Note we support radixes > 16 here.  */
1197     if (!sym
1198         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1199             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1200       {
1201         YYSTYPE newlval;        /* Its value is ignored.  */
1202         hextype = parse_number (tokstart, namelen, 0, &newlval);
1203         if (hextype == INT)
1204           {
1205             yylval.ssym.sym = sym;
1206             yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1207             return NAME_OR_INT;
1208           }
1209       }
1210
1211     /* Any other kind of symbol */
1212     yylval.ssym.sym = sym;
1213     yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1214     return NAME;
1215   }
1216 }
1217
1218 void
1219 yyerror (msg)
1220      char *msg;
1221 {
1222   if (prev_lexptr)
1223     lexptr = prev_lexptr;
1224
1225   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1226 }