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