gdb/f-exp.y

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