gdb/f-exp.y

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