gdb/f-exp.y

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