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