gdb/f-exp.y

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