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 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                                 {
 514                                   write_exp_msymbol (msymbol,
 515                                                      lookup_function_type (builtin_type_int),
 516                                                      builtin_type_int);
 517                                 }
 518                               else if (!have_full_symbols () && !have_partial_symbols ())
 519                                 error ("No symbol table is loaded.  Use the \"file\" command.");
 520                               else
 521                                 error ("No symbol \"%s\" in current context.",
 522                                        copy_name ($1.stoken));
 523                             }
 524                         }
 525         ;
 526
 527
 528 type    :       ptype
 529         ;
 530
 531 ptype   :       typebase
 532         |       typebase abs_decl
 533                 {
 534                   /* This is where the interesting stuff happens.  */
 535                   int done = 0;
 536                   int array_size;
 537                   struct type *follow_type = $1;
 538                   struct type *range_type;
 539
 540                   while (!done)
 541                     switch (pop_type ())
 542                       {
 543                       case tp_end:
 544                         done = 1;
 545                         break;
 546                       case tp_pointer:
 547                         follow_type = lookup_pointer_type (follow_type);
 548                         break;
 549                       case tp_reference:
 550                         follow_type = lookup_reference_type (follow_type);
 551                         break;
 552                       case tp_array:
 553                         array_size = pop_type_int ();
 554                         if (array_size != -1)
 555                           {
 556                             range_type =
 557                               create_range_type ((struct type *) NULL,
 558                                                  builtin_type_f_integer, 0,
 559                                                  array_size - 1);
 560                             follow_type =
 561                               create_array_type ((struct type *) NULL,
 562                                                  follow_type, range_type);
 563                           }
 564                         else
 565                           follow_type = lookup_pointer_type (follow_type);
 566                         break;
 567                       case tp_function:
 568                         follow_type = lookup_function_type (follow_type);
 569                         break;
 570                       }
 571                   $$ = follow_type;
 572                 }
 573         ;
 574
 575 abs_decl:       '*'
 576                         { push_type (tp_pointer); $$ = 0; }
 577         |       '*' abs_decl
 578                         { push_type (tp_pointer); $$ = $2; }
 579         |       '&'
 580                         { push_type (tp_reference); $$ = 0; }
 581         |       '&' abs_decl
 582                         { push_type (tp_reference); $$ = $2; }
 583         |       direct_abs_decl
 584         ;
 585
 586 direct_abs_decl: '(' abs_decl ')'
 587                         { $$ = $2; }
 588         |       direct_abs_decl func_mod
 589                         { push_type (tp_function); }
 590         |       func_mod
 591                         { push_type (tp_function); }
 592         ;
 593
 594 func_mod:       '(' ')'
 595                         { $$ = 0; }
 596         |       '(' nonempty_typelist ')'
 597                         { free ($2); $$ = 0; }
 598         ;
 599
 600 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 601         :       TYPENAME
 602                         { $$ = $1.type; }
 603         |       INT_KEYWORD
 604                         { $$ = builtin_type_f_integer; }
 605         |       INT_S2_KEYWORD
 606                         { $$ = builtin_type_f_integer_s2; }
 607         |       CHARACTER
 608                         { $$ = builtin_type_f_character; }
 609         |       LOGICAL_KEYWORD
 610                         { $$ = builtin_type_f_logical;}
 611         |       LOGICAL_S2_KEYWORD
 612                         { $$ = builtin_type_f_logical_s2;}
 613         |       LOGICAL_S1_KEYWORD
 614                         { $$ = builtin_type_f_logical_s1;}
 615         |       REAL_KEYWORD
 616                         { $$ = builtin_type_f_real;}
 617         |       REAL_S8_KEYWORD
 618                         { $$ = builtin_type_f_real_s8;}
 619         |       REAL_S16_KEYWORD
 620                         { $$ = builtin_type_f_real_s16;}
 621         |       COMPLEX_S8_KEYWORD
 622                         { $$ = builtin_type_f_complex_s8;}
 623         |       COMPLEX_S16_KEYWORD
 624                         { $$ = builtin_type_f_complex_s16;}
 625         |       COMPLEX_S32_KEYWORD
 626                         { $$ = builtin_type_f_complex_s32;}
 627         ;
 628
 629 nonempty_typelist
 630         :       type
 631                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 632                   $<ivec>$[0] = 1;      /* Number of types in vector */
 633                   $$[1] = $1;
 634                 }
 635         |       nonempty_typelist ',' type
 636                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 637                   $$ = (struct type **) realloc ((char *) $1, len);
 638                   $$[$<ivec>$[0]] = $3;
 639                 }
 640         ;
 641
 642 name    :       NAME
 643                 {  $$ = $1.stoken; }
 644         ;
 645
 646 name_not_typename :     NAME
 647 /* These would be useful if name_not_typename was useful, but it is just
 648    a fake for "variable", so these cause reduce/reduce conflicts because
 649    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 650    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 651    context where only a name could occur, this might be useful.
 652         |       NAME_OR_INT
 653    */
 654         ;
 655
 656 %%
 657
 658 /* Take care of parsing a number (anything that starts with a digit).
 659    Set yylval and return the token type; update lexptr.
 660    LEN is the number of characters in it.  */
 661
 662 /*** Needs some error checking for the float case ***/
 663
 664 static int
 665 parse_number (p, len, parsed_float, putithere)
 666      char *p;
 667      int len;
 668      int parsed_float;
 669      YYSTYPE *putithere;
 670 {
 671   LONGEST n = 0;
 672   LONGEST prevn = 0;
 673   int c;
 674   int base = input_radix;
 675   int unsigned_p = 0;
 676   int long_p = 0;
 677   ULONGEST high_bit;
 678   struct type *signed_type;
 679   struct type *unsigned_type;
 680
 681   if (parsed_float)
 682     {
 683       /* It's a float since it contains a point or an exponent.  */
 684       /* [dD] is not understood as an exponent by atof, change it to 'e'.  */
 685       char *tmp, *tmp2;
 686
 687       tmp = xstrdup (p);
 688       for (tmp2 = tmp; *tmp2; ++tmp2)
 689         if (*tmp2 == 'd' || *tmp2 == 'D')
 690           *tmp2 = 'e';
 691       putithere->dval = atof (tmp);
 692       free (tmp);
 693       return FLOAT;
 694     }
 695
 696   /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
 697   if (p[0] == '0')
 698     switch (p[1])
 699       {
 700       case 'x':
 701       case 'X':
 702         if (len >= 3)
 703           {
 704             p += 2;
 705             base = 16;
 706             len -= 2;
 707           }
 708         break;
 709
 710       case 't':
 711       case 'T':
 712       case 'd':
 713       case 'D':
 714         if (len >= 3)
 715           {
 716             p += 2;
 717             base = 10;
 718             len -= 2;
 719           }
 720         break;
 721
 722       default:
 723         base = 8;
 724         break;
 725       }
 726
 727   while (len-- > 0)
 728     {
 729       c = *p++;
 730       if (isupper (c))
 731         c = tolower (c);
 732       if (len == 0 && c == 'l')
 733         long_p = 1;
 734       else if (len == 0 && c == 'u')
 735         unsigned_p = 1;
 736       else
 737         {
 738           int i;
 739           if (c >= '0' && c <= '9')
 740             i = c - '0';
 741           else if (c >= 'a' && c <= 'f')
 742             i = c - 'a' + 10;
 743           else
 744             return ERROR;       /* Char not a digit */
 745           if (i >= base)
 746             return ERROR;               /* Invalid digit in this base */
 747           n *= base;
 748           n += i;
 749         }
 750       /* Portably test for overflow (only works for nonzero values, so make
 751          a second check for zero).  */
 752       if ((prevn >= n) && n != 0)
 753         unsigned_p=1;           /* Try something unsigned */
 754       /* If range checking enabled, portably test for unsigned overflow.  */
 755       if (RANGE_CHECK && n != 0)
 756         {
 757           if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
 758             range_error("Overflow on numeric constant.");
 759         }
 760       prevn = n;
 761     }
 762
 763   /* If the number is too big to be an int, or it's got an l suffix
 764      then it's a long.  Work out if this has to be a long by
 765      shifting right and and seeing if anything remains, and the
 766      target int size is different to the target long size.
 767
 768      In the expression below, we could have tested
 769      (n >> TARGET_INT_BIT)
 770      to see if it was zero,
 771      but too many compilers warn about that, when ints and longs
 772      are the same size.  So we shift it twice, with fewer bits
 773      each time, for the same result.  */
 774
 775   if ((TARGET_INT_BIT != TARGET_LONG_BIT
 776        && ((n >> 2) >> (TARGET_INT_BIT-2)))   /* Avoid shift warning */
 777       || long_p)
 778     {
 779       high_bit = ((ULONGEST)1) << (TARGET_LONG_BIT-1);
 780       unsigned_type = builtin_type_unsigned_long;
 781       signed_type = builtin_type_long;
 782     }
 783   else
 784     {
 785       high_bit = ((ULONGEST)1) << (TARGET_INT_BIT-1);
 786       unsigned_type = builtin_type_unsigned_int;
 787       signed_type = builtin_type_int;
 788     }
 789
 790   putithere->typed_val.val = n;
 791
 792   /* If the high bit of the worked out type is set then this number
 793      has to be unsigned. */
 794
 795   if (unsigned_p || (n & high_bit))
 796     putithere->typed_val.type = unsigned_type;
 797   else
 798     putithere->typed_val.type = signed_type;
 799
 800   return INT;
 801 }
 802
 803 struct token
 804 {
 805   char *operator;
 806   int token;
 807   enum exp_opcode opcode;
 808 };
 809
 810 static const struct token dot_ops[] =
 811 {
 812   { ".and.", BOOL_AND, BINOP_END },
 813   { ".AND.", BOOL_AND, BINOP_END },
 814   { ".or.", BOOL_OR, BINOP_END },
 815   { ".OR.", BOOL_OR, BINOP_END },
 816   { ".not.", BOOL_NOT, BINOP_END },
 817   { ".NOT.", BOOL_NOT, BINOP_END },
 818   { ".eq.", EQUAL, BINOP_END },
 819   { ".EQ.", EQUAL, BINOP_END },
 820   { ".eqv.", EQUAL, BINOP_END },
 821   { ".NEQV.", NOTEQUAL, BINOP_END },
 822   { ".neqv.", NOTEQUAL, BINOP_END },
 823   { ".EQV.", EQUAL, BINOP_END },
 824   { ".ne.", NOTEQUAL, BINOP_END },
 825   { ".NE.", NOTEQUAL, BINOP_END },
 826   { ".le.", LEQ, BINOP_END },
 827   { ".LE.", LEQ, BINOP_END },
 828   { ".ge.", GEQ, BINOP_END },
 829   { ".GE.", GEQ, BINOP_END },
 830   { ".gt.", GREATERTHAN, BINOP_END },
 831   { ".GT.", GREATERTHAN, BINOP_END },
 832   { ".lt.", LESSTHAN, BINOP_END },
 833   { ".LT.", LESSTHAN, BINOP_END },
 834   { NULL, 0, 0 }
 835 };
 836
 837 struct f77_boolean_val
 838 {
 839   char *name;
 840   int value;
 841 };
 842
 843 static const struct f77_boolean_val boolean_values[]  =
 844 {
 845   { ".true.", 1 },
 846   { ".TRUE.", 1 },
 847   { ".false.", 0 },
 848   { ".FALSE.", 0 },
 849   { NULL, 0 }
 850 };
 851
 852 static const struct token f77_keywords[] =
 853 {
 854   { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END },
 855   { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END },
 856   { "character", CHARACTER, BINOP_END },
 857   { "integer_2", INT_S2_KEYWORD, BINOP_END },
 858   { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END },
 859   { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END },
 860   { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END },
 861   { "integer", INT_KEYWORD, BINOP_END },
 862   { "logical", LOGICAL_KEYWORD, BINOP_END },
 863   { "real_16", REAL_S16_KEYWORD, BINOP_END },
 864   { "complex", COMPLEX_S8_KEYWORD, BINOP_END },
 865   { "sizeof", SIZEOF, BINOP_END },
 866   { "real_8", REAL_S8_KEYWORD, BINOP_END },
 867   { "real", REAL_KEYWORD, BINOP_END },
 868   { NULL, 0, 0 }
 869 };
 870
 871 /* Implementation of a dynamically expandable buffer for processing input
 872    characters acquired through lexptr and building a value to return in
 873    yylval. Ripped off from ch-exp.y */
 874
 875 static char *tempbuf;           /* Current buffer contents */
 876 static int tempbufsize;         /* Size of allocated buffer */
 877 static int tempbufindex;        /* Current index into buffer */
 878
 879 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
 880
 881 #define CHECKBUF(size) \
 882   do { \
 883     if (tempbufindex + (size) >= tempbufsize) \
 884       { \
 885         growbuf_by_size (size); \
 886       } \
 887   } while (0);
 888
 889
 890 /* Grow the static temp buffer if necessary, including allocating the first one
 891    on demand. */
 892
 893 static void
 894 growbuf_by_size (count)
 895      int count;
 896 {
 897   int growby;
 898
 899   growby = max (count, GROWBY_MIN_SIZE);
 900   tempbufsize += growby;
 901   if (tempbuf == NULL)
 902     tempbuf = (char *) malloc (tempbufsize);
 903   else
 904     tempbuf = (char *) realloc (tempbuf, tempbufsize);
 905 }
 906
 907 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
 908    string-literals.
 909
 910    Recognize a string literal.  A string literal is a nonzero sequence
 911    of characters enclosed in matching single quotes, except that
 912    a single character inside single quotes is a character literal, which
 913    we reject as a string literal.  To embed the terminator character inside
 914    a string, it is simply doubled (I.E. 'this''is''one''string') */
 915
 916 static int
 917 match_string_literal ()
 918 {
 919   char *tokptr = lexptr;
 920
 921   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
 922     {
 923       CHECKBUF (1);
 924       if (*tokptr == *lexptr)
 925         {
 926           if (*(tokptr + 1) == *lexptr)
 927             tokptr++;
 928           else
 929             break;
 930         }
 931       tempbuf[tempbufindex++] = *tokptr;
 932     }
 933   if (*tokptr == '\0'                                   /* no terminator */
 934       || tempbufindex == 0)                             /* no string */
 935     return 0;
 936   else
 937     {
 938       tempbuf[tempbufindex] = '\0';
 939       yylval.sval.ptr = tempbuf;
 940       yylval.sval.length = tempbufindex;
 941       lexptr = ++tokptr;
 942       return STRING_LITERAL;
 943     }
 944 }
 945
 946 /* Read one token, getting characters through lexptr.  */
 947
 948 static int
 949 yylex ()
 950 {
 951   int c;
 952   int namelen;
 953   unsigned int i,token;
 954   char *tokstart;
 955
 956  retry:
 957
 958   prev_lexptr = lexptr;
 959
 960   tokstart = lexptr;
 961
 962   /* First of all, let us make sure we are not dealing with the
 963      special tokens .true. and .false. which evaluate to 1 and 0.  */
 964
 965   if (*lexptr == '.')
 966     {
 967       for (i = 0; boolean_values[i].name != NULL; i++)
 968         {
 969           if (strncmp (tokstart, boolean_values[i].name,
 970                        strlen (boolean_values[i].name)) == 0)
 971             {
 972               lexptr += strlen (boolean_values[i].name);
 973               yylval.lval = boolean_values[i].value;
 974               return BOOLEAN_LITERAL;
 975             }
 976         }
 977     }
 978
 979   /* See if it is a special .foo. operator.  */
 980
 981   for (i = 0; dot_ops[i].operator != NULL; i++)
 982     if (strncmp (tokstart, dot_ops[i].operator, strlen (dot_ops[i].operator)) == 0)
 983       {
 984         lexptr += strlen (dot_ops[i].operator);
 985         yylval.opcode = dot_ops[i].opcode;
 986         return dot_ops[i].token;
 987       }
 988
 989   /* See if it is an exponentiation operator.  */
 990
 991   if (strncmp (tokstart, "**", 2) == 0)
 992     {
 993       lexptr += 2;
 994       yylval.opcode = BINOP_EXP;
 995       return STARSTAR;
 996     }
 997
 998   switch (c = *tokstart)
 999     {
1000     case 0:
1001       return 0;
1002
1003     case ' ':
1004     case '\t':
1005     case '\n':
1006       lexptr++;
1007       goto retry;
1008
1009     case '\'':
1010       token = match_string_literal ();
1011       if (token != 0)
1012         return (token);
1013       break;
1014
1015     case '(':
1016       paren_depth++;
1017       lexptr++;
1018       return c;
1019
1020     case ')':
1021       if (paren_depth == 0)
1022         return 0;
1023       paren_depth--;
1024       lexptr++;
1025       return c;
1026
1027     case ',':
1028       if (comma_terminates && paren_depth == 0)
1029         return 0;
1030       lexptr++;
1031       return c;
1032
1033     case '.':
1034       /* Might be a floating point number.  */
1035       if (lexptr[1] < '0' || lexptr[1] > '9')
1036         goto symbol;            /* Nope, must be a symbol. */
1037       /* FALL THRU into number case.  */
1038
1039     case '0':
1040     case '1':
1041     case '2':
1042     case '3':
1043     case '4':
1044     case '5':
1045     case '6':
1046     case '7':
1047     case '8':
1048     case '9':
1049       {
1050         /* It's a number.  */
1051         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1052         char *p = tokstart;
1053         int hex = input_radix > 10;
1054
1055         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1056           {
1057             p += 2;
1058             hex = 1;
1059           }
1060         else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D'))
1061           {
1062             p += 2;
1063             hex = 0;
1064           }
1065
1066         for (;; ++p)
1067           {
1068             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1069               got_dot = got_e = 1;
1070             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1071               got_dot = got_d = 1;
1072             else if (!hex && !got_dot && *p == '.')
1073               got_dot = 1;
1074             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1075                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1076                      && (*p == '-' || *p == '+'))
1077               /* This is the sign of the exponent, not the end of the
1078                  number.  */
1079               continue;
1080             /* We will take any letters or digits.  parse_number will
1081                complain if past the radix, or if L or U are not final.  */
1082             else if ((*p < '0' || *p > '9')
1083                      && ((*p < 'a' || *p > 'z')
1084                          && (*p < 'A' || *p > 'Z')))
1085               break;
1086           }
1087         toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d,
1088                                 &yylval);
1089         if (toktype == ERROR)
1090           {
1091             char *err_copy = (char *) alloca (p - tokstart + 1);
1092
1093             memcpy (err_copy, tokstart, p - tokstart);
1094             err_copy[p - tokstart] = 0;
1095             error ("Invalid number \"%s\".", err_copy);
1096           }
1097         lexptr = p;
1098         return toktype;
1099       }
1100
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     case '=':
1119     case '{':
1120     case '}':
1121     symbol:
1122       lexptr++;
1123       return c;
1124     }
1125
1126   if (!(c == '_' || c == '$'
1127         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1128     /* We must have come across a bad character (e.g. ';').  */
1129     error ("Invalid character '%c' in expression.", c);
1130
1131   namelen = 0;
1132   for (c = tokstart[namelen];
1133        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1134         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1135        c = tokstart[++namelen]);
1136
1137   /* The token "if" terminates the expression and is NOT
1138      removed from the input stream.  */
1139
1140   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1141     return 0;
1142
1143   lexptr += namelen;
1144
1145   /* Catch specific keywords.  */
1146
1147   for (i = 0; f77_keywords[i].operator != NULL; i++)
1148     if (strncmp (tokstart, f77_keywords[i].operator,
1149                  strlen(f77_keywords[i].operator)) == 0)
1150       {
1151         /*      lexptr += strlen(f77_keywords[i].operator); */
1152         yylval.opcode = f77_keywords[i].opcode;
1153         return f77_keywords[i].token;
1154       }
1155
1156   yylval.sval.ptr = tokstart;
1157   yylval.sval.length = namelen;
1158
1159   if (*tokstart == '$')
1160     {
1161       write_dollar_variable (yylval.sval);
1162       return VARIABLE;
1163     }
1164
1165   /* Use token-type TYPENAME for symbols that happen to be defined
1166      currently as names of types; NAME for other symbols.
1167      The caller is not constrained to care about the distinction.  */
1168   {
1169     char *tmp = copy_name (yylval.sval);
1170     struct symbol *sym;
1171     int is_a_field_of_this = 0;
1172     int hextype;
1173
1174     sym = lookup_symbol (tmp, expression_context_block,
1175                          VAR_DOMAIN,
1176                          current_language->la_language == language_cplus
1177                          ? &is_a_field_of_this : NULL,
1178                          NULL);
1179     if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1180       {
1181         yylval.tsym.type = SYMBOL_TYPE (sym);
1182         return TYPENAME;
1183       }
1184     yylval.tsym.type
1185       = language_lookup_primitive_type_by_name (current_language,
1186                                                 current_gdbarch, tmp);
1187     if (yylval.tsym.type != NULL)
1188       return TYPENAME;
1189
1190     /* Input names that aren't symbols but ARE valid hex numbers,
1191        when the input radix permits them, can be names or numbers
1192        depending on the parse.  Note we support radixes > 16 here.  */
1193     if (!sym
1194         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1195             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1196       {
1197         YYSTYPE newlval;        /* Its value is ignored.  */
1198         hextype = parse_number (tokstart, namelen, 0, &newlval);
1199         if (hextype == INT)
1200           {
1201             yylval.ssym.sym = sym;
1202             yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1203             return NAME_OR_INT;
1204           }
1205       }
1206
1207     /* Any other kind of symbol */
1208     yylval.ssym.sym = sym;
1209     yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1210     return NAME;
1211   }
1212 }
1213
1214 void
1215 yyerror (msg)
1216      char *msg;
1217 {
1218   if (prev_lexptr)
1219     lexptr = prev_lexptr;
1220
1221   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1222 }