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