gdb/f-exp.y

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