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