gdb/f-exp.y

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