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