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 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 <ssym> name_not_typename
 182
 183 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
 184    but which would parse as a valid number in the current input radix.
 185    E.g. "c" when input_radix==16.  Depending on the parse, it will be
 186    turned into a name or into a number.  */
 187
 188 %token <ssym> NAME_OR_INT
 189
 190 %token  SIZEOF
 191 %token ERROR
 192
 193 /* Special type cases, put in to allow the parser to distinguish different
 194    legal basetypes.  */
 195 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
 196 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
 197 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
 198 %token BOOL_AND BOOL_OR BOOL_NOT
 199 %token <lval> CHARACTER
 200
 201 %token <voidval> VARIABLE
 202
 203 %token <opcode> ASSIGN_MODIFY
 204
 205 %left ','
 206 %left ABOVE_COMMA
 207 %right '=' ASSIGN_MODIFY
 208 %right '?'
 209 %left BOOL_OR
 210 %right BOOL_NOT
 211 %left BOOL_AND
 212 %left '|'
 213 %left '^'
 214 %left '&'
 215 %left EQUAL NOTEQUAL
 216 %left LESSTHAN GREATERTHAN LEQ GEQ
 217 %left LSH RSH
 218 %left '@'
 219 %left '+' '-'
 220 %left '*' '/' '%'
 221 %right STARSTAR
 222 %right UNARY
 223 %right '('
 224
 225 \f
 226 %%
 227
 228 start   :       exp
 229         |       type_exp
 230         ;
 231
 232 type_exp:       type
 233                         { write_exp_elt_opcode(OP_TYPE);
 234                           write_exp_elt_type($1);
 235                           write_exp_elt_opcode(OP_TYPE); }
 236         ;
 237
 238 exp     :       '(' exp ')'
 239                         { }
 240         ;
 241
 242 /* Expressions, not including the comma operator.  */
 243 exp     :       '*' exp    %prec UNARY
 244                         { write_exp_elt_opcode (UNOP_IND); }
 245         ;
 246
 247 exp     :       '&' exp    %prec UNARY
 248                         { write_exp_elt_opcode (UNOP_ADDR); }
 249         ;
 250
 251 exp     :       '-' exp    %prec UNARY
 252                         { write_exp_elt_opcode (UNOP_NEG); }
 253         ;
 254
 255 exp     :       BOOL_NOT exp    %prec UNARY
 256                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 257         ;
 258
 259 exp     :       '~' exp    %prec UNARY
 260                         { write_exp_elt_opcode (UNOP_COMPLEMENT); }
 261         ;
 262
 263 exp     :       SIZEOF exp       %prec UNARY
 264                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 265         ;
 266
 267 /* No more explicit array operators, we treat everything in F77 as
 268    a function call.  The disambiguation as to whether we are
 269    doing a subscript operation or a function call is done
 270    later in eval.c.  */
 271
 272 exp     :       exp '('
 273                         { start_arglist (); }
 274                 arglist ')'
 275                         { write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST);
 276                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 277                           write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); }
 278         ;
 279
 280 arglist :
 281         ;
 282
 283 arglist :       exp
 284                         { arglist_len = 1; }
 285         ;
 286
 287 arglist :       subrange
 288                         { arglist_len = 1; }
 289         ;
 290
 291 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 292                         { arglist_len++; }
 293         ;
 294
 295 /* There are four sorts of subrange types in F90.  */
 296
 297 subrange:       exp ':' exp     %prec ABOVE_COMMA
 298                         { write_exp_elt_opcode (OP_F90_RANGE);
 299                           write_exp_elt_longcst (NONE_BOUND_DEFAULT);
 300                           write_exp_elt_opcode (OP_F90_RANGE); }
 301         ;
 302
 303 subrange:       exp ':' %prec ABOVE_COMMA
 304                         { write_exp_elt_opcode (OP_F90_RANGE);
 305                           write_exp_elt_longcst (HIGH_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 (LOW_BOUND_DEFAULT);
 312                           write_exp_elt_opcode (OP_F90_RANGE); }
 313         ;
 314
 315 subrange:       ':'     %prec ABOVE_COMMA
 316                         { write_exp_elt_opcode (OP_F90_RANGE);
 317                           write_exp_elt_longcst (BOTH_BOUND_DEFAULT);
 318                           write_exp_elt_opcode (OP_F90_RANGE); }
 319         ;
 320
 321 complexnum:     exp ',' exp
 322                         { }
 323         ;
 324
 325 exp     :       '(' complexnum ')'
 326                         { write_exp_elt_opcode(OP_COMPLEX); }
 327         ;
 328
 329 exp     :       '(' type ')' exp  %prec UNARY
 330                         { write_exp_elt_opcode (UNOP_CAST);
 331                           write_exp_elt_type ($2);
 332                           write_exp_elt_opcode (UNOP_CAST); }
 333         ;
 334
 335 /* Binary operators in order of decreasing precedence.  */
 336
 337 exp     :       exp '@' exp
 338                         { write_exp_elt_opcode (BINOP_REPEAT); }
 339         ;
 340
 341 exp     :       exp STARSTAR exp
 342                         { write_exp_elt_opcode (BINOP_EXP); }
 343         ;
 344
 345 exp     :       exp '*' exp
 346                         { write_exp_elt_opcode (BINOP_MUL); }
 347         ;
 348
 349 exp     :       exp '/' exp
 350                         { write_exp_elt_opcode (BINOP_DIV); }
 351         ;
 352
 353 exp     :       exp '%' exp
 354                         { write_exp_elt_opcode (BINOP_REM); }
 355         ;
 356
 357 exp     :       exp '+' exp
 358                         { write_exp_elt_opcode (BINOP_ADD); }
 359         ;
 360
 361 exp     :       exp '-' exp
 362                         { write_exp_elt_opcode (BINOP_SUB); }
 363         ;
 364
 365 exp     :       exp LSH exp
 366                         { write_exp_elt_opcode (BINOP_LSH); }
 367         ;
 368
 369 exp     :       exp RSH exp
 370                         { write_exp_elt_opcode (BINOP_RSH); }
 371         ;
 372
 373 exp     :       exp EQUAL exp
 374                         { write_exp_elt_opcode (BINOP_EQUAL); }
 375         ;
 376
 377 exp     :       exp NOTEQUAL exp
 378                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 379         ;
 380
 381 exp     :       exp LEQ exp
 382                         { write_exp_elt_opcode (BINOP_LEQ); }
 383         ;
 384
 385 exp     :       exp GEQ exp
 386                         { write_exp_elt_opcode (BINOP_GEQ); }
 387         ;
 388
 389 exp     :       exp LESSTHAN exp
 390                         { write_exp_elt_opcode (BINOP_LESS); }
 391         ;
 392
 393 exp     :       exp GREATERTHAN exp
 394                         { write_exp_elt_opcode (BINOP_GTR); }
 395         ;
 396
 397 exp     :       exp '&' exp
 398                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 399         ;
 400
 401 exp     :       exp '^' exp
 402                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 403         ;
 404
 405 exp     :       exp '|' exp
 406                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 407         ;
 408
 409 exp     :       exp BOOL_AND exp
 410                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 411         ;
 412
 413
 414 exp     :       exp BOOL_OR exp
 415                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 416         ;
 417
 418 exp     :       exp '=' exp
 419                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 420         ;
 421
 422 exp     :       exp ASSIGN_MODIFY exp
 423                         { write_exp_elt_opcode (BINOP_ASSIGN_MODIFY);
 424                           write_exp_elt_opcode ($2);
 425                           write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); }
 426         ;
 427
 428 exp     :       INT
 429                         { write_exp_elt_opcode (OP_LONG);
 430                           write_exp_elt_type ($1.type);
 431                           write_exp_elt_longcst ((LONGEST)($1.val));
 432                           write_exp_elt_opcode (OP_LONG); }
 433         ;
 434
 435 exp     :       NAME_OR_INT
 436                         { YYSTYPE val;
 437                           parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val);
 438                           write_exp_elt_opcode (OP_LONG);
 439                           write_exp_elt_type (val.typed_val.type);
 440                           write_exp_elt_longcst ((LONGEST)val.typed_val.val);
 441                           write_exp_elt_opcode (OP_LONG); }
 442         ;
 443
 444 exp     :       FLOAT
 445                         { write_exp_elt_opcode (OP_DOUBLE);
 446                           write_exp_elt_type (builtin_type_f_real_s8);
 447                           write_exp_elt_dblcst ($1);
 448                           write_exp_elt_opcode (OP_DOUBLE); }
 449         ;
 450
 451 exp     :       variable
 452         ;
 453
 454 exp     :       VARIABLE
 455         ;
 456
 457 exp     :       SIZEOF '(' type ')'     %prec UNARY
 458                         { write_exp_elt_opcode (OP_LONG);
 459                           write_exp_elt_type (builtin_type_f_integer);
 460                           CHECK_TYPEDEF ($3);
 461                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 462                           write_exp_elt_opcode (OP_LONG); }
 463         ;
 464
 465 exp     :       BOOLEAN_LITERAL
 466                         { write_exp_elt_opcode (OP_BOOL);
 467                           write_exp_elt_longcst ((LONGEST) $1);
 468                           write_exp_elt_opcode (OP_BOOL);
 469                         }
 470         ;
 471
 472 exp     :       STRING_LITERAL
 473                         {
 474                           write_exp_elt_opcode (OP_STRING);
 475                           write_exp_string ($1);
 476                           write_exp_elt_opcode (OP_STRING);
 477                         }
 478         ;
 479
 480 variable:       name_not_typename
 481                         { struct symbol *sym = $1.sym;
 482
 483                           if (sym)
 484                             {
 485                               if (symbol_read_needs_frame (sym))
 486                                 {
 487                                   if (innermost_block == 0 ||
 488                                       contained_in (block_found,
 489                                                     innermost_block))
 490                                     innermost_block = block_found;
 491                                 }
 492                               write_exp_elt_opcode (OP_VAR_VALUE);
 493                               /* We want to use the selected frame, not
 494                                  another more inner frame which happens to
 495                                  be in the same block.  */
 496                               write_exp_elt_block (NULL);
 497                               write_exp_elt_sym (sym);
 498                               write_exp_elt_opcode (OP_VAR_VALUE);
 499                               break;
 500                             }
 501                           else
 502                             {
 503                               struct minimal_symbol *msymbol;
 504                               char *arg = copy_name ($1.stoken);
 505
 506                               msymbol =
 507                                 lookup_minimal_symbol (arg, NULL, NULL);
 508                               if (msymbol != NULL)
 509                                 {
 510                                   write_exp_msymbol (msymbol,
 511                                                      lookup_function_type (builtin_type_int),
 512                                                      builtin_type_int);
 513                                 }
 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_not_typename :     NAME
 639 /* These would be useful if name_not_typename was useful, but it is just
 640    a fake for "variable", so these cause reduce/reduce conflicts because
 641    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 642    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 643    context where only a name could occur, this might be useful.
 644         |       NAME_OR_INT
 645    */
 646         ;
 647
 648 %%
 649
 650 /* Take care of parsing a number (anything that starts with a digit).
 651    Set yylval and return the token type; update lexptr.
 652    LEN is the number of characters in it.  */
 653
 654 /*** Needs some error checking for the float case ***/
 655
 656 static int
 657 parse_number (p, len, parsed_float, putithere)
 658      char *p;
 659      int len;
 660      int parsed_float;
 661      YYSTYPE *putithere;
 662 {
 663   LONGEST n = 0;
 664   LONGEST prevn = 0;
 665   int c;
 666   int base = input_radix;
 667   int unsigned_p = 0;
 668   int long_p = 0;
 669   ULONGEST high_bit;
 670   struct type *signed_type;
 671   struct type *unsigned_type;
 672
 673   if (parsed_float)
 674     {
 675       /* It's a float since it contains a point or an exponent.  */
 676       /* [dD] is not understood as an exponent by atof, change it to 'e'.  */
 677       char *tmp, *tmp2;
 678
 679       tmp = xstrdup (p);
 680       for (tmp2 = tmp; *tmp2; ++tmp2)
 681         if (*tmp2 == 'd' || *tmp2 == 'D')
 682           *tmp2 = 'e';
 683       putithere->dval = atof (tmp);
 684       free (tmp);
 685       return FLOAT;
 686     }
 687
 688   /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
 689   if (p[0] == '0')
 690     switch (p[1])
 691       {
 692       case 'x':
 693       case 'X':
 694         if (len >= 3)
 695           {
 696             p += 2;
 697             base = 16;
 698             len -= 2;
 699           }
 700         break;
 701
 702       case 't':
 703       case 'T':
 704       case 'd':
 705       case 'D':
 706         if (len >= 3)
 707           {
 708             p += 2;
 709             base = 10;
 710             len -= 2;
 711           }
 712         break;
 713
 714       default:
 715         base = 8;
 716         break;
 717       }
 718
 719   while (len-- > 0)
 720     {
 721       c = *p++;
 722       if (isupper (c))
 723         c = tolower (c);
 724       if (len == 0 && c == 'l')
 725         long_p = 1;
 726       else if (len == 0 && c == 'u')
 727         unsigned_p = 1;
 728       else
 729         {
 730           int i;
 731           if (c >= '0' && c <= '9')
 732             i = c - '0';
 733           else if (c >= 'a' && c <= 'f')
 734             i = c - 'a' + 10;
 735           else
 736             return ERROR;       /* Char not a digit */
 737           if (i >= base)
 738             return ERROR;               /* Invalid digit in this base */
 739           n *= base;
 740           n += i;
 741         }
 742       /* Portably test for overflow (only works for nonzero values, so make
 743          a second check for zero).  */
 744       if ((prevn >= n) && n != 0)
 745         unsigned_p=1;           /* Try something unsigned */
 746       /* If range checking enabled, portably test for unsigned overflow.  */
 747       if (RANGE_CHECK && n != 0)
 748         {
 749           if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
 750             range_error("Overflow on numeric constant.");
 751         }
 752       prevn = n;
 753     }
 754
 755   /* If the number is too big to be an int, or it's got an l suffix
 756      then it's a long.  Work out if this has to be a long by
 757      shifting right and and seeing if anything remains, and the
 758      target int size is different to the target long size.
 759
 760      In the expression below, we could have tested
 761      (n >> TARGET_INT_BIT)
 762      to see if it was zero,
 763      but too many compilers warn about that, when ints and longs
 764      are the same size.  So we shift it twice, with fewer bits
 765      each time, for the same result.  */
 766
 767   if ((TARGET_INT_BIT != TARGET_LONG_BIT
 768        && ((n >> 2) >> (TARGET_INT_BIT-2)))   /* Avoid shift warning */
 769       || long_p)
 770     {
 771       high_bit = ((ULONGEST)1) << (TARGET_LONG_BIT-1);
 772       unsigned_type = builtin_type_unsigned_long;
 773       signed_type = builtin_type_long;
 774     }
 775   else
 776     {
 777       high_bit = ((ULONGEST)1) << (TARGET_INT_BIT-1);
 778       unsigned_type = builtin_type_unsigned_int;
 779       signed_type = builtin_type_int;
 780     }
 781
 782   putithere->typed_val.val = n;
 783
 784   /* If the high bit of the worked out type is set then this number
 785      has to be unsigned. */
 786
 787   if (unsigned_p || (n & high_bit))
 788     putithere->typed_val.type = unsigned_type;
 789   else
 790     putithere->typed_val.type = signed_type;
 791
 792   return INT;
 793 }
 794
 795 struct token
 796 {
 797   char *operator;
 798   int token;
 799   enum exp_opcode opcode;
 800 };
 801
 802 static const struct token dot_ops[] =
 803 {
 804   { ".and.", BOOL_AND, BINOP_END },
 805   { ".AND.", BOOL_AND, BINOP_END },
 806   { ".or.", BOOL_OR, BINOP_END },
 807   { ".OR.", BOOL_OR, BINOP_END },
 808   { ".not.", BOOL_NOT, BINOP_END },
 809   { ".NOT.", BOOL_NOT, BINOP_END },
 810   { ".eq.", EQUAL, BINOP_END },
 811   { ".EQ.", EQUAL, BINOP_END },
 812   { ".eqv.", EQUAL, BINOP_END },
 813   { ".NEQV.", NOTEQUAL, BINOP_END },
 814   { ".neqv.", NOTEQUAL, BINOP_END },
 815   { ".EQV.", EQUAL, BINOP_END },
 816   { ".ne.", NOTEQUAL, BINOP_END },
 817   { ".NE.", NOTEQUAL, BINOP_END },
 818   { ".le.", LEQ, BINOP_END },
 819   { ".LE.", LEQ, BINOP_END },
 820   { ".ge.", GEQ, BINOP_END },
 821   { ".GE.", GEQ, BINOP_END },
 822   { ".gt.", GREATERTHAN, BINOP_END },
 823   { ".GT.", GREATERTHAN, BINOP_END },
 824   { ".lt.", LESSTHAN, BINOP_END },
 825   { ".LT.", LESSTHAN, BINOP_END },
 826   { NULL, 0, 0 }
 827 };
 828
 829 struct f77_boolean_val
 830 {
 831   char *name;
 832   int value;
 833 };
 834
 835 static const struct f77_boolean_val boolean_values[]  =
 836 {
 837   { ".true.", 1 },
 838   { ".TRUE.", 1 },
 839   { ".false.", 0 },
 840   { ".FALSE.", 0 },
 841   { NULL, 0 }
 842 };
 843
 844 static const struct token f77_keywords[] =
 845 {
 846   { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END },
 847   { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END },
 848   { "character", CHARACTER, BINOP_END },
 849   { "integer_2", INT_S2_KEYWORD, BINOP_END },
 850   { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END },
 851   { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END },
 852   { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END },
 853   { "integer", INT_KEYWORD, BINOP_END },
 854   { "logical", LOGICAL_KEYWORD, BINOP_END },
 855   { "real_16", REAL_S16_KEYWORD, BINOP_END },
 856   { "complex", COMPLEX_S8_KEYWORD, BINOP_END },
 857   { "sizeof", SIZEOF, BINOP_END },
 858   { "real_8", REAL_S8_KEYWORD, BINOP_END },
 859   { "real", REAL_KEYWORD, BINOP_END },
 860   { NULL, 0, 0 }
 861 };
 862
 863 /* Implementation of a dynamically expandable buffer for processing input
 864    characters acquired through lexptr and building a value to return in
 865    yylval. Ripped off from ch-exp.y */
 866
 867 static char *tempbuf;           /* Current buffer contents */
 868 static int tempbufsize;         /* Size of allocated buffer */
 869 static int tempbufindex;        /* Current index into buffer */
 870
 871 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
 872
 873 #define CHECKBUF(size) \
 874   do { \
 875     if (tempbufindex + (size) >= tempbufsize) \
 876       { \
 877         growbuf_by_size (size); \
 878       } \
 879   } while (0);
 880
 881
 882 /* Grow the static temp buffer if necessary, including allocating the first one
 883    on demand. */
 884
 885 static void
 886 growbuf_by_size (count)
 887      int count;
 888 {
 889   int growby;
 890
 891   growby = max (count, GROWBY_MIN_SIZE);
 892   tempbufsize += growby;
 893   if (tempbuf == NULL)
 894     tempbuf = (char *) malloc (tempbufsize);
 895   else
 896     tempbuf = (char *) realloc (tempbuf, tempbufsize);
 897 }
 898
 899 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
 900    string-literals.
 901
 902    Recognize a string literal.  A string literal is a nonzero sequence
 903    of characters enclosed in matching single quotes, except that
 904    a single character inside single quotes is a character literal, which
 905    we reject as a string literal.  To embed the terminator character inside
 906    a string, it is simply doubled (I.E. 'this''is''one''string') */
 907
 908 static int
 909 match_string_literal ()
 910 {
 911   char *tokptr = lexptr;
 912
 913   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
 914     {
 915       CHECKBUF (1);
 916       if (*tokptr == *lexptr)
 917         {
 918           if (*(tokptr + 1) == *lexptr)
 919             tokptr++;
 920           else
 921             break;
 922         }
 923       tempbuf[tempbufindex++] = *tokptr;
 924     }
 925   if (*tokptr == '\0'                                   /* no terminator */
 926       || tempbufindex == 0)                             /* no string */
 927     return 0;
 928   else
 929     {
 930       tempbuf[tempbufindex] = '\0';
 931       yylval.sval.ptr = tempbuf;
 932       yylval.sval.length = tempbufindex;
 933       lexptr = ++tokptr;
 934       return STRING_LITERAL;
 935     }
 936 }
 937
 938 /* Read one token, getting characters through lexptr.  */
 939
 940 static int
 941 yylex ()
 942 {
 943   int c;
 944   int namelen;
 945   unsigned int i,token;
 946   char *tokstart;
 947
 948  retry:
 949
 950   prev_lexptr = lexptr;
 951
 952   tokstart = lexptr;
 953
 954   /* First of all, let us make sure we are not dealing with the
 955      special tokens .true. and .false. which evaluate to 1 and 0.  */
 956
 957   if (*lexptr == '.')
 958     {
 959       for (i = 0; boolean_values[i].name != NULL; i++)
 960         {
 961           if (strncmp (tokstart, boolean_values[i].name,
 962                        strlen (boolean_values[i].name)) == 0)
 963             {
 964               lexptr += strlen (boolean_values[i].name);
 965               yylval.lval = boolean_values[i].value;
 966               return BOOLEAN_LITERAL;
 967             }
 968         }
 969     }
 970
 971   /* See if it is a special .foo. operator.  */
 972
 973   for (i = 0; dot_ops[i].operator != NULL; i++)
 974     if (strncmp (tokstart, dot_ops[i].operator, strlen (dot_ops[i].operator)) == 0)
 975       {
 976         lexptr += strlen (dot_ops[i].operator);
 977         yylval.opcode = dot_ops[i].opcode;
 978         return dot_ops[i].token;
 979       }
 980
 981   /* See if it is an exponentiation operator.  */
 982
 983   if (strncmp (tokstart, "**", 2) == 0)
 984     {
 985       lexptr += 2;
 986       yylval.opcode = BINOP_EXP;
 987       return STARSTAR;
 988     }
 989
 990   switch (c = *tokstart)
 991     {
 992     case 0:
 993       return 0;
 994
 995     case ' ':
 996     case '\t':
 997     case '\n':
 998       lexptr++;
 999       goto retry;
1000
1001     case '\'':
1002       token = match_string_literal ();
1003       if (token != 0)
1004         return (token);
1005       break;
1006
1007     case '(':
1008       paren_depth++;
1009       lexptr++;
1010       return c;
1011
1012     case ')':
1013       if (paren_depth == 0)
1014         return 0;
1015       paren_depth--;
1016       lexptr++;
1017       return c;
1018
1019     case ',':
1020       if (comma_terminates && paren_depth == 0)
1021         return 0;
1022       lexptr++;
1023       return c;
1024
1025     case '.':
1026       /* Might be a floating point number.  */
1027       if (lexptr[1] < '0' || lexptr[1] > '9')
1028         goto symbol;            /* Nope, must be a symbol. */
1029       /* FALL THRU into number case.  */
1030
1031     case '0':
1032     case '1':
1033     case '2':
1034     case '3':
1035     case '4':
1036     case '5':
1037     case '6':
1038     case '7':
1039     case '8':
1040     case '9':
1041       {
1042         /* It's a number.  */
1043         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1044         char *p = tokstart;
1045         int hex = input_radix > 10;
1046
1047         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1048           {
1049             p += 2;
1050             hex = 1;
1051           }
1052         else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D'))
1053           {
1054             p += 2;
1055             hex = 0;
1056           }
1057
1058         for (;; ++p)
1059           {
1060             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1061               got_dot = got_e = 1;
1062             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1063               got_dot = got_d = 1;
1064             else if (!hex && !got_dot && *p == '.')
1065               got_dot = 1;
1066             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1067                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1068                      && (*p == '-' || *p == '+'))
1069               /* This is the sign of the exponent, not the end of the
1070                  number.  */
1071               continue;
1072             /* We will take any letters or digits.  parse_number will
1073                complain if past the radix, or if L or U are not final.  */
1074             else if ((*p < '0' || *p > '9')
1075                      && ((*p < 'a' || *p > 'z')
1076                          && (*p < 'A' || *p > 'Z')))
1077               break;
1078           }
1079         toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d,
1080                                 &yylval);
1081         if (toktype == ERROR)
1082           {
1083             char *err_copy = (char *) alloca (p - tokstart + 1);
1084
1085             memcpy (err_copy, tokstart, p - tokstart);
1086             err_copy[p - tokstart] = 0;
1087             error ("Invalid number \"%s\".", err_copy);
1088           }
1089         lexptr = p;
1090         return toktype;
1091       }
1092
1093     case '+':
1094     case '-':
1095     case '*':
1096     case '/':
1097     case '%':
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     symbol:
1114       lexptr++;
1115       return c;
1116     }
1117
1118   if (!(c == '_' || c == '$'
1119         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1120     /* We must have come across a bad character (e.g. ';').  */
1121     error ("Invalid character '%c' in expression.", c);
1122
1123   namelen = 0;
1124   for (c = tokstart[namelen];
1125        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1126         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1127        c = tokstart[++namelen]);
1128
1129   /* The token "if" terminates the expression and is NOT
1130      removed from the input stream.  */
1131
1132   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1133     return 0;
1134
1135   lexptr += namelen;
1136
1137   /* Catch specific keywords.  */
1138
1139   for (i = 0; f77_keywords[i].operator != NULL; i++)
1140     if (strncmp (tokstart, f77_keywords[i].operator,
1141                  strlen(f77_keywords[i].operator)) == 0)
1142       {
1143         /*      lexptr += strlen(f77_keywords[i].operator); */
1144         yylval.opcode = f77_keywords[i].opcode;
1145         return f77_keywords[i].token;
1146       }
1147
1148   yylval.sval.ptr = tokstart;
1149   yylval.sval.length = namelen;
1150
1151   if (*tokstart == '$')
1152     {
1153       write_dollar_variable (yylval.sval);
1154       return VARIABLE;
1155     }
1156
1157   /* Use token-type TYPENAME for symbols that happen to be defined
1158      currently as names of types; NAME for other symbols.
1159      The caller is not constrained to care about the distinction.  */
1160   {
1161     char *tmp = copy_name (yylval.sval);
1162     struct symbol *sym;
1163     int is_a_field_of_this = 0;
1164     int hextype;
1165
1166     sym = lookup_symbol (tmp, expression_context_block,
1167                          VAR_DOMAIN,
1168                          current_language->la_language == language_cplus
1169                          ? &is_a_field_of_this : NULL,
1170                          NULL);
1171     if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1172       {
1173         yylval.tsym.type = SYMBOL_TYPE (sym);
1174         return TYPENAME;
1175       }
1176     yylval.tsym.type
1177       = language_lookup_primitive_type_by_name (current_language,
1178                                                 current_gdbarch, tmp);
1179     if (yylval.tsym.type != NULL)
1180       return TYPENAME;
1181
1182     /* Input names that aren't symbols but ARE valid hex numbers,
1183        when the input radix permits them, can be names or numbers
1184        depending on the parse.  Note we support radixes > 16 here.  */
1185     if (!sym
1186         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1187             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1188       {
1189         YYSTYPE newlval;        /* Its value is ignored.  */
1190         hextype = parse_number (tokstart, namelen, 0, &newlval);
1191         if (hextype == INT)
1192           {
1193             yylval.ssym.sym = sym;
1194             yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1195             return NAME_OR_INT;
1196           }
1197       }
1198
1199     /* Any other kind of symbol */
1200     yylval.ssym.sym = sym;
1201     yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1202     return NAME;
1203   }
1204 }
1205
1206 void
1207 yyerror (msg)
1208      char *msg;
1209 {
1210   if (prev_lexptr)
1211     lexptr = prev_lexptr;
1212
1213   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1214 }