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 <ctype.h>
  57
  58 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
  59    as well as gratuitiously global symbol names, so we can have multiple
  60    yacc generated parsers in gdb.  Note that these are only the variables
  61    produced by yacc.  If other parser generators (bison, byacc, etc) produce
  62    additional global names that conflict at link time, then those parser
  63    generators need to be fixed instead of adding those names to this list. */
  64
  65 #define yymaxdepth f_maxdepth
  66 #define yyparse f_parse
  67 #define yylex   f_lex
  68 #define yyerror f_error
  69 #define yylval  f_lval
  70 #define yychar  f_char
  71 #define yydebug f_debug
  72 #define yypact  f_pact
  73 #define yyr1    f_r1
  74 #define yyr2    f_r2
  75 #define yydef   f_def
  76 #define yychk   f_chk
  77 #define yypgo   f_pgo
  78 #define yyact   f_act
  79 #define yyexca  f_exca
  80 #define yyerrflag f_errflag
  81 #define yynerrs f_nerrs
  82 #define yyps    f_ps
  83 #define yypv    f_pv
  84 #define yys     f_s
  85 #define yy_yys  f_yys
  86 #define yystate f_state
  87 #define yytmp   f_tmp
  88 #define yyv     f_v
  89 #define yy_yyv  f_yyv
  90 #define yyval   f_val
  91 #define yylloc  f_lloc
  92 #define yyreds  f_reds          /* With YYDEBUG defined */
  93 #define yytoks  f_toks          /* With YYDEBUG defined */
  94 #define yylhs   f_yylhs
  95 #define yylen   f_yylen
  96 #define yydefred f_yydefred
  97 #define yydgoto f_yydgoto
  98 #define yysindex f_yysindex
  99 #define yyrindex f_yyrindex
 100 #define yygindex f_yygindex
 101 #define yytable  f_yytable
 102 #define yycheck  f_yycheck
 103
 104 #ifndef YYDEBUG
 105 #define YYDEBUG 1               /* Default to no yydebug support */
 106 #endif
 107
 108 int yyparse (void);
 109
 110 static int yylex (void);
 111
 112 void yyerror (char *);
 113
 114 static void growbuf_by_size (int);
 115
 116 static int match_string_literal (void);
 117
 118 %}
 119
 120 /* Although the yacc "value" of an expression is not used,
 121    since the result is stored in the structure being created,
 122    other node types do have values.  */
 123
 124 %union
 125   {
 126     LONGEST lval;
 127     struct {
 128       LONGEST val;
 129       struct type *type;
 130     } typed_val;
 131     DOUBLEST dval;
 132     struct symbol *sym;
 133     struct type *tval;
 134     struct stoken sval;
 135     struct ttype tsym;
 136     struct symtoken ssym;
 137     int voidval;
 138     struct block *bval;
 139     enum exp_opcode opcode;
 140     struct internalvar *ivar;
 141
 142     struct type **tvec;
 143     int *ivec;
 144   }
 145
 146 %{
 147 /* YYSTYPE gets defined by %union */
 148 static int parse_number (char *, int, int, YYSTYPE *);
 149 %}
 150
 151 %type <voidval> exp  type_exp start variable
 152 %type <tval> type typebase
 153 %type <tvec> nonempty_typelist
 154 /* %type <bval> block */
 155
 156 /* Fancy type parsing.  */
 157 %type <voidval> func_mod direct_abs_decl abs_decl
 158 %type <tval> ptype
 159
 160 %token <typed_val> INT
 161 %token <dval> FLOAT
 162
 163 /* Both NAME and TYPENAME tokens represent symbols in the input,
 164    and both convey their data as strings.
 165    But a TYPENAME is a string that happens to be defined as a typedef
 166    or builtin type name (such as int or char)
 167    and a NAME is any other symbol.
 168    Contexts where this distinction is not important can use the
 169    nonterminal "name", which matches either NAME or TYPENAME.  */
 170
 171 %token <sval> STRING_LITERAL
 172 %token <lval> BOOLEAN_LITERAL
 173 %token <ssym> NAME
 174 %token <tsym> TYPENAME
 175 %type <sval> name
 176 %type <ssym> name_not_typename
 177 %type <tsym> typename
 178
 179 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
 180    but which would parse as a valid number in the current input radix.
 181    E.g. "c" when input_radix==16.  Depending on the parse, it will be
 182    turned into a name or into a number.  */
 183
 184 %token <ssym> NAME_OR_INT
 185
 186 %token  SIZEOF
 187 %token ERROR
 188
 189 /* Special type cases, put in to allow the parser to distinguish different
 190    legal basetypes.  */
 191 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
 192 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
 193 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
 194 %token BOOL_AND BOOL_OR BOOL_NOT
 195 %token <lval> CHARACTER
 196
 197 %token <voidval> VARIABLE
 198
 199 %token <opcode> ASSIGN_MODIFY
 200
 201 %left ','
 202 %left ABOVE_COMMA
 203 %right '=' ASSIGN_MODIFY
 204 %right '?'
 205 %left BOOL_OR
 206 %right BOOL_NOT
 207 %left BOOL_AND
 208 %left '|'
 209 %left '^'
 210 %left '&'
 211 %left EQUAL NOTEQUAL
 212 %left LESSTHAN GREATERTHAN LEQ GEQ
 213 %left LSH RSH
 214 %left '@'
 215 %left '+' '-'
 216 %left '*' '/' '%'
 217 %right UNARY
 218 %right '('
 219
 220 \f
 221 %%
 222
 223 start   :       exp
 224         |       type_exp
 225         ;
 226
 227 type_exp:       type
 228                         { write_exp_elt_opcode(OP_TYPE);
 229                           write_exp_elt_type($1);
 230                           write_exp_elt_opcode(OP_TYPE); }
 231         ;
 232
 233 exp     :       '(' exp ')'
 234                         { }
 235         ;
 236
 237 /* Expressions, not including the comma operator.  */
 238 exp     :       '*' exp    %prec UNARY
 239                         { write_exp_elt_opcode (UNOP_IND); }
 240
 241 exp     :       '&' exp    %prec UNARY
 242                         { write_exp_elt_opcode (UNOP_ADDR); }
 243
 244 exp     :       '-' exp    %prec UNARY
 245                         { write_exp_elt_opcode (UNOP_NEG); }
 246         ;
 247
 248 exp     :       BOOL_NOT exp    %prec UNARY
 249                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 250         ;
 251
 252 exp     :       '~' exp    %prec UNARY
 253                         { write_exp_elt_opcode (UNOP_COMPLEMENT); }
 254         ;
 255
 256 exp     :       SIZEOF exp       %prec UNARY
 257                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 258         ;
 259
 260 /* No more explicit array operators, we treat everything in F77 as
 261    a function call.  The disambiguation as to whether we are
 262    doing a subscript operation or a function call is done
 263    later in eval.c.  */
 264
 265 exp     :       exp '('
 266                         { start_arglist (); }
 267                 arglist ')'
 268                         { write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST);
 269                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 270                           write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); }
 271         ;
 272
 273 arglist :
 274         ;
 275
 276 arglist :       exp
 277                         { arglist_len = 1; }
 278         ;
 279
 280 arglist :      substring
 281                         { arglist_len = 2;}
 282
 283 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 284                         { arglist_len++; }
 285         ;
 286
 287 substring:      exp ':' exp   %prec ABOVE_COMMA
 288                         { }
 289         ;
 290
 291
 292 complexnum:     exp ',' exp
 293                         { }
 294         ;
 295
 296 exp     :       '(' complexnum ')'
 297                         { write_exp_elt_opcode(OP_COMPLEX); }
 298         ;
 299
 300 exp     :       '(' type ')' exp  %prec UNARY
 301                         { write_exp_elt_opcode (UNOP_CAST);
 302                           write_exp_elt_type ($2);
 303                           write_exp_elt_opcode (UNOP_CAST); }
 304         ;
 305
 306 /* Binary operators in order of decreasing precedence.  */
 307
 308 exp     :       exp '@' exp
 309                         { write_exp_elt_opcode (BINOP_REPEAT); }
 310         ;
 311
 312 exp     :       exp '*' exp
 313                         { write_exp_elt_opcode (BINOP_MUL); }
 314         ;
 315
 316 exp     :       exp '/' exp
 317                         { write_exp_elt_opcode (BINOP_DIV); }
 318         ;
 319
 320 exp     :       exp '%' exp
 321                         { write_exp_elt_opcode (BINOP_REM); }
 322         ;
 323
 324 exp     :       exp '+' exp
 325                         { write_exp_elt_opcode (BINOP_ADD); }
 326         ;
 327
 328 exp     :       exp '-' exp
 329                         { write_exp_elt_opcode (BINOP_SUB); }
 330         ;
 331
 332 exp     :       exp LSH exp
 333                         { write_exp_elt_opcode (BINOP_LSH); }
 334         ;
 335
 336 exp     :       exp RSH exp
 337                         { write_exp_elt_opcode (BINOP_RSH); }
 338         ;
 339
 340 exp     :       exp EQUAL exp
 341                         { write_exp_elt_opcode (BINOP_EQUAL); }
 342         ;
 343
 344 exp     :       exp NOTEQUAL exp
 345                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 346         ;
 347
 348 exp     :       exp LEQ exp
 349                         { write_exp_elt_opcode (BINOP_LEQ); }
 350         ;
 351
 352 exp     :       exp GEQ exp
 353                         { write_exp_elt_opcode (BINOP_GEQ); }
 354         ;
 355
 356 exp     :       exp LESSTHAN exp
 357                         { write_exp_elt_opcode (BINOP_LESS); }
 358         ;
 359
 360 exp     :       exp GREATERTHAN exp
 361                         { write_exp_elt_opcode (BINOP_GTR); }
 362         ;
 363
 364 exp     :       exp '&' exp
 365                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 366         ;
 367
 368 exp     :       exp '^' exp
 369                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 370         ;
 371
 372 exp     :       exp '|' exp
 373                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 374         ;
 375
 376 exp     :       exp BOOL_AND exp
 377                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 378         ;
 379
 380
 381 exp     :       exp BOOL_OR exp
 382                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 383         ;
 384
 385 exp     :       exp '=' exp
 386                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 387         ;
 388
 389 exp     :       exp ASSIGN_MODIFY exp
 390                         { write_exp_elt_opcode (BINOP_ASSIGN_MODIFY);
 391                           write_exp_elt_opcode ($2);
 392                           write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); }
 393         ;
 394
 395 exp     :       INT
 396                         { write_exp_elt_opcode (OP_LONG);
 397                           write_exp_elt_type ($1.type);
 398                           write_exp_elt_longcst ((LONGEST)($1.val));
 399                           write_exp_elt_opcode (OP_LONG); }
 400         ;
 401
 402 exp     :       NAME_OR_INT
 403                         { YYSTYPE val;
 404                           parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val);
 405                           write_exp_elt_opcode (OP_LONG);
 406                           write_exp_elt_type (val.typed_val.type);
 407                           write_exp_elt_longcst ((LONGEST)val.typed_val.val);
 408                           write_exp_elt_opcode (OP_LONG); }
 409         ;
 410
 411 exp     :       FLOAT
 412                         { write_exp_elt_opcode (OP_DOUBLE);
 413                           write_exp_elt_type (builtin_type_f_real_s8);
 414                           write_exp_elt_dblcst ($1);
 415                           write_exp_elt_opcode (OP_DOUBLE); }
 416         ;
 417
 418 exp     :       variable
 419         ;
 420
 421 exp     :       VARIABLE
 422         ;
 423
 424 exp     :       SIZEOF '(' type ')'     %prec UNARY
 425                         { write_exp_elt_opcode (OP_LONG);
 426                           write_exp_elt_type (builtin_type_f_integer);
 427                           CHECK_TYPEDEF ($3);
 428                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 429                           write_exp_elt_opcode (OP_LONG); }
 430         ;
 431
 432 exp     :       BOOLEAN_LITERAL
 433                         { write_exp_elt_opcode (OP_BOOL);
 434                           write_exp_elt_longcst ((LONGEST) $1);
 435                           write_exp_elt_opcode (OP_BOOL);
 436                         }
 437         ;
 438
 439 exp     :       STRING_LITERAL
 440                         {
 441                           write_exp_elt_opcode (OP_STRING);
 442                           write_exp_string ($1);
 443                           write_exp_elt_opcode (OP_STRING);
 444                         }
 445         ;
 446
 447 variable:       name_not_typename
 448                         { struct symbol *sym = $1.sym;
 449
 450                           if (sym)
 451                             {
 452                               if (symbol_read_needs_frame (sym))
 453                                 {
 454                                   if (innermost_block == 0 ||
 455                                       contained_in (block_found,
 456                                                     innermost_block))
 457                                     innermost_block = block_found;
 458                                 }
 459                               write_exp_elt_opcode (OP_VAR_VALUE);
 460                               /* We want to use the selected frame, not
 461                                  another more inner frame which happens to
 462                                  be in the same block.  */
 463                               write_exp_elt_block (NULL);
 464                               write_exp_elt_sym (sym);
 465                               write_exp_elt_opcode (OP_VAR_VALUE);
 466                               break;
 467                             }
 468                           else
 469                             {
 470                               struct minimal_symbol *msymbol;
 471                               register char *arg = copy_name ($1.stoken);
 472
 473                               msymbol =
 474                                 lookup_minimal_symbol (arg, NULL, NULL);
 475                               if (msymbol != NULL)
 476                                 {
 477                                   write_exp_msymbol (msymbol,
 478                                                      lookup_function_type (builtin_type_int),
 479                                                      builtin_type_int);
 480                                 }
 481                               else if (!have_full_symbols () && !have_partial_symbols ())
 482                                 error ("No symbol table is loaded.  Use the \"file\" command.");
 483                               else
 484                                 error ("No symbol \"%s\" in current context.",
 485                                        copy_name ($1.stoken));
 486                             }
 487                         }
 488         ;
 489
 490
 491 type    :       ptype
 492         ;
 493
 494 ptype   :       typebase
 495         |       typebase abs_decl
 496                 {
 497                   /* This is where the interesting stuff happens.  */
 498                   int done = 0;
 499                   int array_size;
 500                   struct type *follow_type = $1;
 501                   struct type *range_type;
 502
 503                   while (!done)
 504                     switch (pop_type ())
 505                       {
 506                       case tp_end:
 507                         done = 1;
 508                         break;
 509                       case tp_pointer:
 510                         follow_type = lookup_pointer_type (follow_type);
 511                         break;
 512                       case tp_reference:
 513                         follow_type = lookup_reference_type (follow_type);
 514                         break;
 515                       case tp_array:
 516                         array_size = pop_type_int ();
 517                         if (array_size != -1)
 518                           {
 519                             range_type =
 520                               create_range_type ((struct type *) NULL,
 521                                                  builtin_type_f_integer, 0,
 522                                                  array_size - 1);
 523                             follow_type =
 524                               create_array_type ((struct type *) NULL,
 525                                                  follow_type, range_type);
 526                           }
 527                         else
 528                           follow_type = lookup_pointer_type (follow_type);
 529                         break;
 530                       case tp_function:
 531                         follow_type = lookup_function_type (follow_type);
 532                         break;
 533                       }
 534                   $$ = follow_type;
 535                 }
 536         ;
 537
 538 abs_decl:       '*'
 539                         { push_type (tp_pointer); $$ = 0; }
 540         |       '*' abs_decl
 541                         { push_type (tp_pointer); $$ = $2; }
 542         |       '&'
 543                         { push_type (tp_reference); $$ = 0; }
 544         |       '&' abs_decl
 545                         { push_type (tp_reference); $$ = $2; }
 546         |       direct_abs_decl
 547         ;
 548
 549 direct_abs_decl: '(' abs_decl ')'
 550                         { $$ = $2; }
 551         |       direct_abs_decl func_mod
 552                         { push_type (tp_function); }
 553         |       func_mod
 554                         { push_type (tp_function); }
 555         ;
 556
 557 func_mod:       '(' ')'
 558                         { $$ = 0; }
 559         |       '(' nonempty_typelist ')'
 560                         { free ((PTR)$2); $$ = 0; }
 561         ;
 562
 563 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 564         :       TYPENAME
 565                         { $$ = $1.type; }
 566         |       INT_KEYWORD
 567                         { $$ = builtin_type_f_integer; }
 568         |       INT_S2_KEYWORD
 569                         { $$ = builtin_type_f_integer_s2; }
 570         |       CHARACTER
 571                         { $$ = builtin_type_f_character; }
 572         |       LOGICAL_KEYWORD
 573                         { $$ = builtin_type_f_logical;}
 574         |       LOGICAL_S2_KEYWORD
 575                         { $$ = builtin_type_f_logical_s2;}
 576         |       LOGICAL_S1_KEYWORD
 577                         { $$ = builtin_type_f_logical_s1;}
 578         |       REAL_KEYWORD
 579                         { $$ = builtin_type_f_real;}
 580         |       REAL_S8_KEYWORD
 581                         { $$ = builtin_type_f_real_s8;}
 582         |       REAL_S16_KEYWORD
 583                         { $$ = builtin_type_f_real_s16;}
 584         |       COMPLEX_S8_KEYWORD
 585                         { $$ = builtin_type_f_complex_s8;}
 586         |       COMPLEX_S16_KEYWORD
 587                         { $$ = builtin_type_f_complex_s16;}
 588         |       COMPLEX_S32_KEYWORD
 589                         { $$ = builtin_type_f_complex_s32;}
 590         ;
 591
 592 typename:       TYPENAME
 593         ;
 594
 595 nonempty_typelist
 596         :       type
 597                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 598                   $<ivec>$[0] = 1;      /* Number of types in vector */
 599                   $$[1] = $1;
 600                 }
 601         |       nonempty_typelist ',' type
 602                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 603                   $$ = (struct type **) realloc ((char *) $1, len);
 604                   $$[$<ivec>$[0]] = $3;
 605                 }
 606         ;
 607
 608 name    :       NAME
 609                         { $$ = $1.stoken; }
 610         |       TYPENAME
 611                         { $$ = $1.stoken; }
 612         |       NAME_OR_INT
 613                         { $$ = $1.stoken; }
 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      register char *p;
 637      register int len;
 638      int parsed_float;
 639      YYSTYPE *putithere;
 640 {
 641   register LONGEST n = 0;
 642   register LONGEST prevn = 0;
 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 (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 STREQN (tokstart, boolean_values[i].name,
 940                     strlen (boolean_values[i].name))
 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 (STREQN (tokstart, dot_ops[i].operator, strlen (dot_ops[i].operator)))
 953       {
 954         lexptr += strlen (dot_ops[i].operator);
 955         yylval.opcode = dot_ops[i].opcode;
 956         return dot_ops[i].token;
 957       }
 958
 959   switch (c = *tokstart)
 960     {
 961     case 0:
 962       return 0;
 963
 964     case ' ':
 965     case '\t':
 966     case '\n':
 967       lexptr++;
 968       goto retry;
 969
 970     case '\'':
 971       token = match_string_literal ();
 972       if (token != 0)
 973         return (token);
 974       break;
 975
 976     case '(':
 977       paren_depth++;
 978       lexptr++;
 979       return c;
 980
 981     case ')':
 982       if (paren_depth == 0)
 983         return 0;
 984       paren_depth--;
 985       lexptr++;
 986       return c;
 987
 988     case ',':
 989       if (comma_terminates && paren_depth == 0)
 990         return 0;
 991       lexptr++;
 992       return c;
 993
 994     case '.':
 995       /* Might be a floating point number.  */
 996       if (lexptr[1] < '0' || lexptr[1] > '9')
 997         goto symbol;            /* Nope, must be a symbol. */
 998       /* FALL THRU into number case.  */
 999
1000     case '0':
1001     case '1':
1002     case '2':
1003     case '3':
1004     case '4':
1005     case '5':
1006     case '6':
1007     case '7':
1008     case '8':
1009     case '9':
1010       {
1011         /* It's a number.  */
1012         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1013         register char *p = tokstart;
1014         int hex = input_radix > 10;
1015
1016         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1017           {
1018             p += 2;
1019             hex = 1;
1020           }
1021         else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D'))
1022           {
1023             p += 2;
1024             hex = 0;
1025           }
1026
1027         for (;; ++p)
1028           {
1029             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1030               got_dot = got_e = 1;
1031             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1032               got_dot = got_d = 1;
1033             else if (!hex && !got_dot && *p == '.')
1034               got_dot = 1;
1035             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1036                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1037                      && (*p == '-' || *p == '+'))
1038               /* This is the sign of the exponent, not the end of the
1039                  number.  */
1040               continue;
1041             /* We will take any letters or digits.  parse_number will
1042                complain if past the radix, or if L or U are not final.  */
1043             else if ((*p < '0' || *p > '9')
1044                      && ((*p < 'a' || *p > 'z')
1045                          && (*p < 'A' || *p > 'Z')))
1046               break;
1047           }
1048         toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d,
1049                                 &yylval);
1050         if (toktype == ERROR)
1051           {
1052             char *err_copy = (char *) alloca (p - tokstart + 1);
1053
1054             memcpy (err_copy, tokstart, p - tokstart);
1055             err_copy[p - tokstart] = 0;
1056             error ("Invalid number \"%s\".", err_copy);
1057           }
1058         lexptr = p;
1059         return toktype;
1060       }
1061
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     case '{':
1081     case '}':
1082     symbol:
1083       lexptr++;
1084       return c;
1085     }
1086
1087   if (!(c == '_' || c == '$'
1088         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1089     /* We must have come across a bad character (e.g. ';').  */
1090     error ("Invalid character '%c' in expression.", c);
1091
1092   namelen = 0;
1093   for (c = tokstart[namelen];
1094        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1095         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1096        c = tokstart[++namelen]);
1097
1098   /* The token "if" terminates the expression and is NOT
1099      removed from the input stream.  */
1100
1101   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1102     return 0;
1103
1104   lexptr += namelen;
1105
1106   /* Catch specific keywords.  */
1107
1108   for (i = 0; f77_keywords[i].operator != NULL; i++)
1109     if (STREQN(tokstart, f77_keywords[i].operator,
1110                strlen(f77_keywords[i].operator)))
1111       {
1112         /*      lexptr += strlen(f77_keywords[i].operator); */
1113         yylval.opcode = f77_keywords[i].opcode;
1114         return f77_keywords[i].token;
1115       }
1116
1117   yylval.sval.ptr = tokstart;
1118   yylval.sval.length = namelen;
1119
1120   if (*tokstart == '$')
1121     {
1122       write_dollar_variable (yylval.sval);
1123       return VARIABLE;
1124     }
1125
1126   /* Use token-type TYPENAME for symbols that happen to be defined
1127      currently as names of types; NAME for other symbols.
1128      The caller is not constrained to care about the distinction.  */
1129   {
1130     char *tmp = copy_name (yylval.sval);
1131     struct symbol *sym;
1132     int is_a_field_of_this = 0;
1133     int hextype;
1134
1135     sym = lookup_symbol (tmp, expression_context_block,
1136                          VAR_NAMESPACE,
1137                          current_language->la_language == language_cplus
1138                          ? &is_a_field_of_this : NULL,
1139                          NULL);
1140     if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1141       {
1142         yylval.tsym.type = SYMBOL_TYPE (sym);
1143         return TYPENAME;
1144       }
1145     if ((yylval.tsym.type = lookup_primitive_typename (tmp)) != 0)
1146       return TYPENAME;
1147
1148     /* Input names that aren't symbols but ARE valid hex numbers,
1149        when the input radix permits them, can be names or numbers
1150        depending on the parse.  Note we support radixes > 16 here.  */
1151     if (!sym
1152         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1153             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1154       {
1155         YYSTYPE newlval;        /* Its value is ignored.  */
1156         hextype = parse_number (tokstart, namelen, 0, &newlval);
1157         if (hextype == INT)
1158           {
1159             yylval.ssym.sym = sym;
1160             yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1161             return NAME_OR_INT;
1162           }
1163       }
1164
1165     /* Any other kind of symbol */
1166     yylval.ssym.sym = sym;
1167     yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1168     return NAME;
1169   }
1170 }
1171
1172 void
1173 yyerror (msg)
1174      char *msg;
1175 {
1176   if (prev_lexptr)
1177     lexptr = prev_lexptr;
1178
1179   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1180 }