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    2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   4
   5    Contributed by Motorola.  Adapted from the C parser by Farooq Butt
   6    (fmbutt@engage.sps.mot.com).
   7
   8 This file is part of GDB.
   9
  10 This program is free software; you can redistribute it and/or modify
  11 it under the terms of the GNU General Public License as published by
  12 the Free Software Foundation; either version 2 of the License, or
  13 (at your option) any later version.
  14
  15 This program is distributed in the hope that it will be useful,
  16 but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 GNU General Public License for more details.
  19
  20 You should have received a copy of the GNU General Public License
  21 along with this program; if not, write to the Free Software
  22 Foundation, Inc., 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 STARSTAR
 221 %right UNARY
 222 %right '('
 223
 224 \f
 225 %%
 226
 227 start   :       exp
 228         |       type_exp
 229         ;
 230
 231 type_exp:       type
 232                         { write_exp_elt_opcode(OP_TYPE);
 233                           write_exp_elt_type($1);
 234                           write_exp_elt_opcode(OP_TYPE); }
 235         ;
 236
 237 exp     :       '(' exp ')'
 238                         { }
 239         ;
 240
 241 /* Expressions, not including the comma operator.  */
 242 exp     :       '*' exp    %prec UNARY
 243                         { write_exp_elt_opcode (UNOP_IND); }
 244         ;
 245
 246 exp     :       '&' exp    %prec UNARY
 247                         { write_exp_elt_opcode (UNOP_ADDR); }
 248         ;
 249
 250 exp     :       '-' exp    %prec UNARY
 251                         { write_exp_elt_opcode (UNOP_NEG); }
 252         ;
 253
 254 exp     :       BOOL_NOT exp    %prec UNARY
 255                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 256         ;
 257
 258 exp     :       '~' exp    %prec UNARY
 259                         { write_exp_elt_opcode (UNOP_COMPLEMENT); }
 260         ;
 261
 262 exp     :       SIZEOF exp       %prec UNARY
 263                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 264         ;
 265
 266 /* No more explicit array operators, we treat everything in F77 as
 267    a function call.  The disambiguation as to whether we are
 268    doing a subscript operation or a function call is done
 269    later in eval.c.  */
 270
 271 exp     :       exp '('
 272                         { start_arglist (); }
 273                 arglist ')'
 274                         { write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST);
 275                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 276                           write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); }
 277         ;
 278
 279 arglist :
 280         ;
 281
 282 arglist :       exp
 283                         { arglist_len = 1; }
 284         ;
 285
 286 arglist :      substring
 287                         { arglist_len = 2;}
 288         ;
 289
 290 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 291                         { arglist_len++; }
 292         ;
 293
 294 substring:      exp ':' exp   %prec ABOVE_COMMA
 295                         { }
 296         ;
 297
 298
 299 complexnum:     exp ',' exp
 300                         { }
 301         ;
 302
 303 exp     :       '(' complexnum ')'
 304                         { write_exp_elt_opcode(OP_COMPLEX); }
 305         ;
 306
 307 exp     :       '(' type ')' exp  %prec UNARY
 308                         { write_exp_elt_opcode (UNOP_CAST);
 309                           write_exp_elt_type ($2);
 310                           write_exp_elt_opcode (UNOP_CAST); }
 311         ;
 312
 313 /* Binary operators in order of decreasing precedence.  */
 314
 315 exp     :       exp '@' exp
 316                         { write_exp_elt_opcode (BINOP_REPEAT); }
 317         ;
 318
 319 exp     :       exp STARSTAR exp
 320                         { write_exp_elt_opcode (BINOP_EXP); }
 321         ;
 322
 323 exp     :       exp '*' exp
 324                         { write_exp_elt_opcode (BINOP_MUL); }
 325         ;
 326
 327 exp     :       exp '/' exp
 328                         { write_exp_elt_opcode (BINOP_DIV); }
 329         ;
 330
 331 exp     :       exp '%' exp
 332                         { write_exp_elt_opcode (BINOP_REM); }
 333         ;
 334
 335 exp     :       exp '+' exp
 336                         { write_exp_elt_opcode (BINOP_ADD); }
 337         ;
 338
 339 exp     :       exp '-' exp
 340                         { write_exp_elt_opcode (BINOP_SUB); }
 341         ;
 342
 343 exp     :       exp LSH exp
 344                         { write_exp_elt_opcode (BINOP_LSH); }
 345         ;
 346
 347 exp     :       exp RSH exp
 348                         { write_exp_elt_opcode (BINOP_RSH); }
 349         ;
 350
 351 exp     :       exp EQUAL exp
 352                         { write_exp_elt_opcode (BINOP_EQUAL); }
 353         ;
 354
 355 exp     :       exp NOTEQUAL exp
 356                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 357         ;
 358
 359 exp     :       exp LEQ exp
 360                         { write_exp_elt_opcode (BINOP_LEQ); }
 361         ;
 362
 363 exp     :       exp GEQ exp
 364                         { write_exp_elt_opcode (BINOP_GEQ); }
 365         ;
 366
 367 exp     :       exp LESSTHAN exp
 368                         { write_exp_elt_opcode (BINOP_LESS); }
 369         ;
 370
 371 exp     :       exp GREATERTHAN exp
 372                         { write_exp_elt_opcode (BINOP_GTR); }
 373         ;
 374
 375 exp     :       exp '&' exp
 376                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 377         ;
 378
 379 exp     :       exp '^' exp
 380                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 381         ;
 382
 383 exp     :       exp '|' exp
 384                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 385         ;
 386
 387 exp     :       exp BOOL_AND exp
 388                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 389         ;
 390
 391
 392 exp     :       exp BOOL_OR exp
 393                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 394         ;
 395
 396 exp     :       exp '=' exp
 397                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 398         ;
 399
 400 exp     :       exp ASSIGN_MODIFY exp
 401                         { write_exp_elt_opcode (BINOP_ASSIGN_MODIFY);
 402                           write_exp_elt_opcode ($2);
 403                           write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); }
 404         ;
 405
 406 exp     :       INT
 407                         { write_exp_elt_opcode (OP_LONG);
 408                           write_exp_elt_type ($1.type);
 409                           write_exp_elt_longcst ((LONGEST)($1.val));
 410                           write_exp_elt_opcode (OP_LONG); }
 411         ;
 412
 413 exp     :       NAME_OR_INT
 414                         { YYSTYPE val;
 415                           parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val);
 416                           write_exp_elt_opcode (OP_LONG);
 417                           write_exp_elt_type (val.typed_val.type);
 418                           write_exp_elt_longcst ((LONGEST)val.typed_val.val);
 419                           write_exp_elt_opcode (OP_LONG); }
 420         ;
 421
 422 exp     :       FLOAT
 423                         { write_exp_elt_opcode (OP_DOUBLE);
 424                           write_exp_elt_type (builtin_type_f_real_s8);
 425                           write_exp_elt_dblcst ($1);
 426                           write_exp_elt_opcode (OP_DOUBLE); }
 427         ;
 428
 429 exp     :       variable
 430         ;
 431
 432 exp     :       VARIABLE
 433         ;
 434
 435 exp     :       SIZEOF '(' type ')'     %prec UNARY
 436                         { write_exp_elt_opcode (OP_LONG);
 437                           write_exp_elt_type (builtin_type_f_integer);
 438                           CHECK_TYPEDEF ($3);
 439                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 440                           write_exp_elt_opcode (OP_LONG); }
 441         ;
 442
 443 exp     :       BOOLEAN_LITERAL
 444                         { write_exp_elt_opcode (OP_BOOL);
 445                           write_exp_elt_longcst ((LONGEST) $1);
 446                           write_exp_elt_opcode (OP_BOOL);
 447                         }
 448         ;
 449
 450 exp     :       STRING_LITERAL
 451                         {
 452                           write_exp_elt_opcode (OP_STRING);
 453                           write_exp_string ($1);
 454                           write_exp_elt_opcode (OP_STRING);
 455                         }
 456         ;
 457
 458 variable:       name_not_typename
 459                         { struct symbol *sym = $1.sym;
 460
 461                           if (sym)
 462                             {
 463                               if (symbol_read_needs_frame (sym))
 464                                 {
 465                                   if (innermost_block == 0 ||
 466                                       contained_in (block_found,
 467                                                     innermost_block))
 468                                     innermost_block = block_found;
 469                                 }
 470                               write_exp_elt_opcode (OP_VAR_VALUE);
 471                               /* We want to use the selected frame, not
 472                                  another more inner frame which happens to
 473                                  be in the same block.  */
 474                               write_exp_elt_block (NULL);
 475                               write_exp_elt_sym (sym);
 476                               write_exp_elt_opcode (OP_VAR_VALUE);
 477                               break;
 478                             }
 479                           else
 480                             {
 481                               struct minimal_symbol *msymbol;
 482                               char *arg = copy_name ($1.stoken);
 483
 484                               msymbol =
 485                                 lookup_minimal_symbol (arg, NULL, NULL);
 486                               if (msymbol != NULL)
 487                                 {
 488                                   write_exp_msymbol (msymbol,
 489                                                      lookup_function_type (builtin_type_int),
 490                                                      builtin_type_int);
 491                                 }
 492                               else if (!have_full_symbols () && !have_partial_symbols ())
 493                                 error ("No symbol table is loaded.  Use the \"file\" command.");
 494                               else
 495                                 error ("No symbol \"%s\" in current context.",
 496                                        copy_name ($1.stoken));
 497                             }
 498                         }
 499         ;
 500
 501
 502 type    :       ptype
 503         ;
 504
 505 ptype   :       typebase
 506         |       typebase abs_decl
 507                 {
 508                   /* This is where the interesting stuff happens.  */
 509                   int done = 0;
 510                   int array_size;
 511                   struct type *follow_type = $1;
 512                   struct type *range_type;
 513
 514                   while (!done)
 515                     switch (pop_type ())
 516                       {
 517                       case tp_end:
 518                         done = 1;
 519                         break;
 520                       case tp_pointer:
 521                         follow_type = lookup_pointer_type (follow_type);
 522                         break;
 523                       case tp_reference:
 524                         follow_type = lookup_reference_type (follow_type);
 525                         break;
 526                       case tp_array:
 527                         array_size = pop_type_int ();
 528                         if (array_size != -1)
 529                           {
 530                             range_type =
 531                               create_range_type ((struct type *) NULL,
 532                                                  builtin_type_f_integer, 0,
 533                                                  array_size - 1);
 534                             follow_type =
 535                               create_array_type ((struct type *) NULL,
 536                                                  follow_type, range_type);
 537                           }
 538                         else
 539                           follow_type = lookup_pointer_type (follow_type);
 540                         break;
 541                       case tp_function:
 542                         follow_type = lookup_function_type (follow_type);
 543                         break;
 544                       }
 545                   $$ = follow_type;
 546                 }
 547         ;
 548
 549 abs_decl:       '*'
 550                         { push_type (tp_pointer); $$ = 0; }
 551         |       '*' abs_decl
 552                         { push_type (tp_pointer); $$ = $2; }
 553         |       '&'
 554                         { push_type (tp_reference); $$ = 0; }
 555         |       '&' abs_decl
 556                         { push_type (tp_reference); $$ = $2; }
 557         |       direct_abs_decl
 558         ;
 559
 560 direct_abs_decl: '(' abs_decl ')'
 561                         { $$ = $2; }
 562         |       direct_abs_decl func_mod
 563                         { push_type (tp_function); }
 564         |       func_mod
 565                         { push_type (tp_function); }
 566         ;
 567
 568 func_mod:       '(' ')'
 569                         { $$ = 0; }
 570         |       '(' nonempty_typelist ')'
 571                         { free ($2); $$ = 0; }
 572         ;
 573
 574 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 575         :       TYPENAME
 576                         { $$ = $1.type; }
 577         |       INT_KEYWORD
 578                         { $$ = builtin_type_f_integer; }
 579         |       INT_S2_KEYWORD
 580                         { $$ = builtin_type_f_integer_s2; }
 581         |       CHARACTER
 582                         { $$ = builtin_type_f_character; }
 583         |       LOGICAL_KEYWORD
 584                         { $$ = builtin_type_f_logical;}
 585         |       LOGICAL_S2_KEYWORD
 586                         { $$ = builtin_type_f_logical_s2;}
 587         |       LOGICAL_S1_KEYWORD
 588                         { $$ = builtin_type_f_logical_s1;}
 589         |       REAL_KEYWORD
 590                         { $$ = builtin_type_f_real;}
 591         |       REAL_S8_KEYWORD
 592                         { $$ = builtin_type_f_real_s8;}
 593         |       REAL_S16_KEYWORD
 594                         { $$ = builtin_type_f_real_s16;}
 595         |       COMPLEX_S8_KEYWORD
 596                         { $$ = builtin_type_f_complex_s8;}
 597         |       COMPLEX_S16_KEYWORD
 598                         { $$ = builtin_type_f_complex_s16;}
 599         |       COMPLEX_S32_KEYWORD
 600                         { $$ = builtin_type_f_complex_s32;}
 601         ;
 602
 603 nonempty_typelist
 604         :       type
 605                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 606                   $<ivec>$[0] = 1;      /* Number of types in vector */
 607                   $$[1] = $1;
 608                 }
 609         |       nonempty_typelist ',' type
 610                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 611                   $$ = (struct type **) realloc ((char *) $1, len);
 612                   $$[$<ivec>$[0]] = $3;
 613                 }
 614         ;
 615
 616 name_not_typename :     NAME
 617 /* These would be useful if name_not_typename was useful, but it is just
 618    a fake for "variable", so these cause reduce/reduce conflicts because
 619    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 620    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 621    context where only a name could occur, this might be useful.
 622         |       NAME_OR_INT
 623    */
 624         ;
 625
 626 %%
 627
 628 /* Take care of parsing a number (anything that starts with a digit).
 629    Set yylval and return the token type; update lexptr.
 630    LEN is the number of characters in it.  */
 631
 632 /*** Needs some error checking for the float case ***/
 633
 634 static int
 635 parse_number (p, len, parsed_float, putithere)
 636      char *p;
 637      int len;
 638      int parsed_float;
 639      YYSTYPE *putithere;
 640 {
 641   LONGEST n = 0;
 642   LONGEST prevn = 0;
 643   int c;
 644   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 (isupper (c))
 701         c = tolower (c);
 702       if (len == 0 && c == 'l')
 703         long_p = 1;
 704       else if (len == 0 && c == 'u')
 705         unsigned_p = 1;
 706       else
 707         {
 708           int i;
 709           if (c >= '0' && c <= '9')
 710             i = c - '0';
 711           else if (c >= 'a' && c <= 'f')
 712             i = c - 'a' + 10;
 713           else
 714             return ERROR;       /* Char not a digit */
 715           if (i >= base)
 716             return ERROR;               /* Invalid digit in this base */
 717           n *= base;
 718           n += i;
 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   prev_lexptr = lexptr;
 929
 930   tokstart = lexptr;
 931
 932   /* First of all, let us make sure we are not dealing with the
 933      special tokens .true. and .false. which evaluate to 1 and 0.  */
 934
 935   if (*lexptr == '.')
 936     {
 937       for (i = 0; boolean_values[i].name != NULL; i++)
 938         {
 939           if (strncmp (tokstart, boolean_values[i].name,
 940                        strlen (boolean_values[i].name)) == 0)
 941             {
 942               lexptr += strlen (boolean_values[i].name);
 943               yylval.lval = boolean_values[i].value;
 944               return BOOLEAN_LITERAL;
 945             }
 946         }
 947     }
 948
 949   /* See if it is a special .foo. operator.  */
 950
 951   for (i = 0; dot_ops[i].operator != NULL; i++)
 952     if (strncmp (tokstart, dot_ops[i].operator, strlen (dot_ops[i].operator)) == 0)
 953       {
 954         lexptr += strlen (dot_ops[i].operator);
 955         yylval.opcode = dot_ops[i].opcode;
 956         return dot_ops[i].token;
 957       }
 958
 959   /* See if it is an exponentiation operator.  */
 960
 961   if (strncmp (tokstart, "**", 2) == 0)
 962     {
 963       lexptr += 2;
 964       yylval.opcode = BINOP_EXP;
 965       return STARSTAR;
 966     }
 967
 968   switch (c = *tokstart)
 969     {
 970     case 0:
 971       return 0;
 972
 973     case ' ':
 974     case '\t':
 975     case '\n':
 976       lexptr++;
 977       goto retry;
 978
 979     case '\'':
 980       token = match_string_literal ();
 981       if (token != 0)
 982         return (token);
 983       break;
 984
 985     case '(':
 986       paren_depth++;
 987       lexptr++;
 988       return c;
 989
 990     case ')':
 991       if (paren_depth == 0)
 992         return 0;
 993       paren_depth--;
 994       lexptr++;
 995       return c;
 996
 997     case ',':
 998       if (comma_terminates && paren_depth == 0)
 999         return 0;
1000       lexptr++;
1001       return c;
1002
1003     case '.':
1004       /* Might be a floating point number.  */
1005       if (lexptr[1] < '0' || lexptr[1] > '9')
1006         goto symbol;            /* Nope, must be a symbol. */
1007       /* FALL THRU into number case.  */
1008
1009     case '0':
1010     case '1':
1011     case '2':
1012     case '3':
1013     case '4':
1014     case '5':
1015     case '6':
1016     case '7':
1017     case '8':
1018     case '9':
1019       {
1020         /* It's a number.  */
1021         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1022         char *p = tokstart;
1023         int hex = input_radix > 10;
1024
1025         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1026           {
1027             p += 2;
1028             hex = 1;
1029           }
1030         else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D'))
1031           {
1032             p += 2;
1033             hex = 0;
1034           }
1035
1036         for (;; ++p)
1037           {
1038             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1039               got_dot = got_e = 1;
1040             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1041               got_dot = got_d = 1;
1042             else if (!hex && !got_dot && *p == '.')
1043               got_dot = 1;
1044             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1045                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1046                      && (*p == '-' || *p == '+'))
1047               /* This is the sign of the exponent, not the end of the
1048                  number.  */
1049               continue;
1050             /* We will take any letters or digits.  parse_number will
1051                complain if past the radix, or if L or U are not final.  */
1052             else if ((*p < '0' || *p > '9')
1053                      && ((*p < 'a' || *p > 'z')
1054                          && (*p < 'A' || *p > 'Z')))
1055               break;
1056           }
1057         toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d,
1058                                 &yylval);
1059         if (toktype == ERROR)
1060           {
1061             char *err_copy = (char *) alloca (p - tokstart + 1);
1062
1063             memcpy (err_copy, tokstart, p - tokstart);
1064             err_copy[p - tokstart] = 0;
1065             error ("Invalid number \"%s\".", err_copy);
1066           }
1067         lexptr = p;
1068         return toktype;
1069       }
1070
1071     case '+':
1072     case '-':
1073     case '*':
1074     case '/':
1075     case '%':
1076     case '|':
1077     case '&':
1078     case '^':
1079     case '~':
1080     case '!':
1081     case '@':
1082     case '<':
1083     case '>':
1084     case '[':
1085     case ']':
1086     case '?':
1087     case ':':
1088     case '=':
1089     case '{':
1090     case '}':
1091     symbol:
1092       lexptr++;
1093       return c;
1094     }
1095
1096   if (!(c == '_' || c == '$'
1097         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1098     /* We must have come across a bad character (e.g. ';').  */
1099     error ("Invalid character '%c' in expression.", c);
1100
1101   namelen = 0;
1102   for (c = tokstart[namelen];
1103        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1104         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1105        c = tokstart[++namelen]);
1106
1107   /* The token "if" terminates the expression and is NOT
1108      removed from the input stream.  */
1109
1110   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1111     return 0;
1112
1113   lexptr += namelen;
1114
1115   /* Catch specific keywords.  */
1116
1117   for (i = 0; f77_keywords[i].operator != NULL; i++)
1118     if (strncmp (tokstart, f77_keywords[i].operator,
1119                  strlen(f77_keywords[i].operator)) == 0)
1120       {
1121         /*      lexptr += strlen(f77_keywords[i].operator); */
1122         yylval.opcode = f77_keywords[i].opcode;
1123         return f77_keywords[i].token;
1124       }
1125
1126   yylval.sval.ptr = tokstart;
1127   yylval.sval.length = namelen;
1128
1129   if (*tokstart == '$')
1130     {
1131       write_dollar_variable (yylval.sval);
1132       return VARIABLE;
1133     }
1134
1135   /* Use token-type TYPENAME for symbols that happen to be defined
1136      currently as names of types; NAME for other symbols.
1137      The caller is not constrained to care about the distinction.  */
1138   {
1139     char *tmp = copy_name (yylval.sval);
1140     struct symbol *sym;
1141     int is_a_field_of_this = 0;
1142     int hextype;
1143
1144     sym = lookup_symbol (tmp, expression_context_block,
1145                          VAR_DOMAIN,
1146                          current_language->la_language == language_cplus
1147                          ? &is_a_field_of_this : NULL,
1148                          NULL);
1149     if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1150       {
1151         yylval.tsym.type = SYMBOL_TYPE (sym);
1152         return TYPENAME;
1153       }
1154     yylval.tsym.type
1155       = language_lookup_primitive_type_by_name (current_language,
1156                                                 current_gdbarch, tmp);
1157     if (yylval.tsym.type != NULL)
1158       return TYPENAME;
1159
1160     /* Input names that aren't symbols but ARE valid hex numbers,
1161        when the input radix permits them, can be names or numbers
1162        depending on the parse.  Note we support radixes > 16 here.  */
1163     if (!sym
1164         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1165             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1166       {
1167         YYSTYPE newlval;        /* Its value is ignored.  */
1168         hextype = parse_number (tokstart, namelen, 0, &newlval);
1169         if (hextype == INT)
1170           {
1171             yylval.ssym.sym = sym;
1172             yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1173             return NAME_OR_INT;
1174           }
1175       }
1176
1177     /* Any other kind of symbol */
1178     yylval.ssym.sym = sym;
1179     yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1180     return NAME;
1181   }
1182 }
1183
1184 void
1185 yyerror (msg)
1186      char *msg;
1187 {
1188   if (prev_lexptr)
1189     lexptr = prev_lexptr;
1190
1191   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1192 }