gdb/f-exp.y

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