contrib/gdb-7/gdb/f-exp.y

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