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