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