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