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 #define yylhs   f_yylhs
  93 #define yylen   f_yylen
  94 #define yydefred f_yydefred
  95 #define yydgoto f_yydgoto
  96 #define yysindex f_yysindex
  97 #define yyrindex f_yyrindex
  98 #define yygindex f_yygindex
  99 #define yytable  f_yytable
 100 #define yycheck  f_yycheck
 101
 102 #ifndef YYDEBUG
 103 #define YYDEBUG 1               /* Default to no yydebug support */
 104 #endif
 105
 106 int yyparse PARAMS ((void));
 107
 108 static int yylex PARAMS ((void));
 109
 110 void yyerror PARAMS ((char *));
 111
 112 %}
 113
 114 /* Although the yacc "value" of an expression is not used,
 115    since the result is stored in the structure being created,
 116    other node types do have values.  */
 117
 118 %union
 119   {
 120     LONGEST lval;
 121     struct {
 122       LONGEST val;
 123       struct type *type;
 124     } typed_val;
 125     double dval;
 126     struct symbol *sym;
 127     struct type *tval;
 128     struct stoken sval;
 129     struct ttype tsym;
 130     struct symtoken ssym;
 131     int voidval;
 132     struct block *bval;
 133     enum exp_opcode opcode;
 134     struct internalvar *ivar;
 135
 136     struct type **tvec;
 137     int *ivec;
 138   }
 139
 140 %{
 141 /* YYSTYPE gets defined by %union */
 142 static int parse_number PARAMS ((char *, int, int, YYSTYPE *));
 143 %}
 144
 145 %type <voidval> exp  type_exp start variable
 146 %type <tval> type typebase
 147 %type <tvec> nonempty_typelist
 148 /* %type <bval> block */
 149
 150 /* Fancy type parsing.  */
 151 %type <voidval> func_mod direct_abs_decl abs_decl
 152 %type <tval> ptype
 153
 154 %token <typed_val> INT
 155 %token <dval> FLOAT
 156
 157 /* Both NAME and TYPENAME tokens represent symbols in the input,
 158    and both convey their data as strings.
 159    But a TYPENAME is a string that happens to be defined as a typedef
 160    or builtin type name (such as int or char)
 161    and a NAME is any other symbol.
 162    Contexts where this distinction is not important can use the
 163    nonterminal "name", which matches either NAME or TYPENAME.  */
 164
 165 %token <sval> STRING_LITERAL
 166 %token <lval> BOOLEAN_LITERAL
 167 %token <ssym> NAME
 168 %token <tsym> TYPENAME
 169 %type <sval> name
 170 %type <ssym> name_not_typename
 171 %type <tsym> typename
 172
 173 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
 174    but which would parse as a valid number in the current input radix.
 175    E.g. "c" when input_radix==16.  Depending on the parse, it will be
 176    turned into a name or into a number.  */
 177
 178 %token <ssym> NAME_OR_INT
 179
 180 %token  SIZEOF
 181 %token ERROR
 182
 183 /* Special type cases, put in to allow the parser to distinguish different
 184    legal basetypes.  */
 185 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
 186 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
 187 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
 188 %token BOOL_AND BOOL_OR BOOL_NOT
 189 %token <lval> LAST REGNAME CHARACTER
 190
 191 %token <ivar> VARIABLE
 192
 193 %token <opcode> ASSIGN_MODIFY
 194
 195 %left ','
 196 %left ABOVE_COMMA
 197 %right '=' ASSIGN_MODIFY
 198 %right '?'
 199 %left BOOL_OR
 200 %right BOOL_NOT
 201 %left BOOL_AND
 202 %left '|'
 203 %left '^'
 204 %left '&'
 205 %left EQUAL NOTEQUAL
 206 %left LESSTHAN GREATERTHAN LEQ GEQ
 207 %left LSH RSH
 208 %left '@'
 209 %left '+' '-'
 210 %left '*' '/' '%'
 211 %right UNARY
 212 %right '('
 213
 214 \f
 215 %%
 216
 217 start   :       exp
 218         |       type_exp
 219         ;
 220
 221 type_exp:       type
 222                         { write_exp_elt_opcode(OP_TYPE);
 223                           write_exp_elt_type($1);
 224                           write_exp_elt_opcode(OP_TYPE); }
 225         ;
 226
 227 exp     :       '(' exp ')'
 228                         { }
 229         ;
 230
 231 /* Expressions, not including the comma operator.  */
 232 exp     :       '*' exp    %prec UNARY
 233                         { write_exp_elt_opcode (UNOP_IND); }
 234
 235 exp     :       '&' exp    %prec UNARY
 236                         { write_exp_elt_opcode (UNOP_ADDR); }
 237
 238 exp     :       '-' exp    %prec UNARY
 239                         { write_exp_elt_opcode (UNOP_NEG); }
 240         ;
 241
 242 exp     :       BOOL_NOT exp    %prec UNARY
 243                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 244         ;
 245
 246 exp     :       '~' exp    %prec UNARY
 247                         { write_exp_elt_opcode (UNOP_COMPLEMENT); }
 248         ;
 249
 250 exp     :       SIZEOF exp       %prec UNARY
 251                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 252         ;
 253
 254 /* No more explicit array operators, we treat everything in F77 as
 255    a function call.  The disambiguation as to whether we are
 256    doing a subscript operation or a function call is done
 257    later in eval.c.  */
 258
 259 exp     :       exp '('
 260                         { start_arglist (); }
 261                 arglist ')'
 262                         { write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST);
 263                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 264                           write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); }
 265         ;
 266
 267 arglist :
 268         ;
 269
 270 arglist :       exp
 271                         { arglist_len = 1; }
 272         ;
 273
 274 arglist :      substring
 275                         { arglist_len = 2;}
 276
 277 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 278                         { arglist_len++; }
 279         ;
 280
 281 substring:      exp ':' exp   %prec ABOVE_COMMA
 282                         { }
 283         ;
 284
 285
 286 complexnum:     exp ',' exp
 287                         { }
 288         ;
 289
 290 exp     :       '(' complexnum ')'
 291                         { write_exp_elt_opcode(OP_COMPLEX); }
 292         ;
 293
 294 exp     :       '(' type ')' exp  %prec UNARY
 295                         { write_exp_elt_opcode (UNOP_CAST);
 296                           write_exp_elt_type ($2);
 297                           write_exp_elt_opcode (UNOP_CAST); }
 298         ;
 299
 300 /* Binary operators in order of decreasing precedence.  */
 301
 302 exp     :       exp '@' exp
 303                         { write_exp_elt_opcode (BINOP_REPEAT); }
 304         ;
 305
 306 exp     :       exp '*' exp
 307                         { write_exp_elt_opcode (BINOP_MUL); }
 308         ;
 309
 310 exp     :       exp '/' exp
 311                         { write_exp_elt_opcode (BINOP_DIV); }
 312         ;
 313
 314 exp     :       exp '%' exp
 315                         { write_exp_elt_opcode (BINOP_REM); }
 316         ;
 317
 318 exp     :       exp '+' exp
 319                         { write_exp_elt_opcode (BINOP_ADD); }
 320         ;
 321
 322 exp     :       exp '-' exp
 323                         { write_exp_elt_opcode (BINOP_SUB); }
 324         ;
 325
 326 exp     :       exp LSH exp
 327                         { write_exp_elt_opcode (BINOP_LSH); }
 328         ;
 329
 330 exp     :       exp RSH exp
 331                         { write_exp_elt_opcode (BINOP_RSH); }
 332         ;
 333
 334 exp     :       exp EQUAL exp
 335                         { write_exp_elt_opcode (BINOP_EQUAL); }
 336         ;
 337
 338 exp     :       exp NOTEQUAL exp
 339                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 340         ;
 341
 342 exp     :       exp LEQ exp
 343                         { write_exp_elt_opcode (BINOP_LEQ); }
 344         ;
 345
 346 exp     :       exp GEQ exp
 347                         { write_exp_elt_opcode (BINOP_GEQ); }
 348         ;
 349
 350 exp     :       exp LESSTHAN exp
 351                         { write_exp_elt_opcode (BINOP_LESS); }
 352         ;
 353
 354 exp     :       exp GREATERTHAN exp
 355                         { write_exp_elt_opcode (BINOP_GTR); }
 356         ;
 357
 358 exp     :       exp '&' exp
 359                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 360         ;
 361
 362 exp     :       exp '^' exp
 363                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 364         ;
 365
 366 exp     :       exp '|' exp
 367                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 368         ;
 369
 370 exp     :       exp BOOL_AND exp
 371                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 372         ;
 373
 374
 375 exp     :       exp BOOL_OR exp
 376                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 377         ;
 378
 379 exp     :       exp '=' exp
 380                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 381         ;
 382
 383 exp     :       exp ASSIGN_MODIFY exp
 384                         { write_exp_elt_opcode (BINOP_ASSIGN_MODIFY);
 385                           write_exp_elt_opcode ($2);
 386                           write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); }
 387         ;
 388
 389 exp     :       INT
 390                         { write_exp_elt_opcode (OP_LONG);
 391                           write_exp_elt_type ($1.type);
 392                           write_exp_elt_longcst ((LONGEST)($1.val));
 393                           write_exp_elt_opcode (OP_LONG); }
 394         ;
 395
 396 exp     :       NAME_OR_INT
 397                         { YYSTYPE val;
 398                           parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val);
 399                           write_exp_elt_opcode (OP_LONG);
 400                           write_exp_elt_type (val.typed_val.type);
 401                           write_exp_elt_longcst ((LONGEST)val.typed_val.val);
 402                           write_exp_elt_opcode (OP_LONG); }
 403         ;
 404
 405 exp     :       FLOAT
 406                         { write_exp_elt_opcode (OP_DOUBLE);
 407                           write_exp_elt_type (builtin_type_f_real_s8);
 408                           write_exp_elt_dblcst ($1);
 409                           write_exp_elt_opcode (OP_DOUBLE); }
 410         ;
 411
 412 exp     :       variable
 413         ;
 414
 415 exp     :       LAST
 416                         { write_exp_elt_opcode (OP_LAST);
 417                           write_exp_elt_longcst ((LONGEST) $1);
 418                           write_exp_elt_opcode (OP_LAST); }
 419         ;
 420
 421 exp     :       REGNAME
 422                         { write_exp_elt_opcode (OP_REGISTER);
 423                           write_exp_elt_longcst ((LONGEST) $1);
 424                           write_exp_elt_opcode (OP_REGISTER); }
 425         ;
 426
 427 exp     :       VARIABLE
 428                         { write_exp_elt_opcode (OP_INTERNALVAR);
 429                           write_exp_elt_intern ($1);
 430                           write_exp_elt_opcode (OP_INTERNALVAR); }
 431         ;
 432
 433 exp     :       SIZEOF '(' type ')'     %prec UNARY
 434                         { write_exp_elt_opcode (OP_LONG);
 435                           write_exp_elt_type (builtin_type_f_integer);
 436                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 437                           write_exp_elt_opcode (OP_LONG); }
 438         ;
 439
 440 exp     :       BOOLEAN_LITERAL
 441                         { write_exp_elt_opcode (OP_BOOL);
 442                           write_exp_elt_longcst ((LONGEST) $1);
 443                           write_exp_elt_opcode (OP_BOOL);
 444                         }
 445         ;
 446
 447 exp     :       STRING_LITERAL
 448                         {
 449                           write_exp_elt_opcode (OP_STRING);
 450                           write_exp_string ($1);
 451                           write_exp_elt_opcode (OP_STRING);
 452                         }
 453         ;
 454
 455 variable:       name_not_typename
 456                         { struct symbol *sym = $1.sym;
 457
 458                           if (sym)
 459                             {
 460                               if (symbol_read_needs_frame (sym))
 461                                 {
 462                                   if (innermost_block == 0 ||
 463                                       contained_in (block_found,
 464                                                     innermost_block))
 465                                     innermost_block = block_found;
 466                                 }
 467                               write_exp_elt_opcode (OP_VAR_VALUE);
 468                               /* We want to use the selected frame, not
 469                                  another more inner frame which happens to
 470                                  be in the same block.  */
 471                               write_exp_elt_block (NULL);
 472                               write_exp_elt_sym (sym);
 473                               write_exp_elt_opcode (OP_VAR_VALUE);
 474                               break;
 475                             }
 476                           else
 477                             {
 478                               struct minimal_symbol *msymbol;
 479                               register char *arg = copy_name ($1.stoken);
 480
 481                               msymbol =
 482                                 lookup_minimal_symbol (arg, NULL, NULL);
 483                               if (msymbol != NULL)
 484                                 {
 485                                   write_exp_msymbol (msymbol,
 486                                                      lookup_function_type (builtin_type_int),
 487                                                      builtin_type_int);
 488                                 }
 489                               else if (!have_full_symbols () && !have_partial_symbols ())
 490                                 error ("No symbol table is loaded.  Use the \"file\" command.");
 491                               else
 492                                 error ("No symbol \"%s\" in current context.",
 493                                        copy_name ($1.stoken));
 494                             }
 495                         }
 496         ;
 497
 498
 499 type    :       ptype
 500         ;
 501
 502 ptype   :       typebase
 503         |       typebase abs_decl
 504                 {
 505                   /* This is where the interesting stuff happens.  */
 506                   int done = 0;
 507                   int array_size;
 508                   struct type *follow_type = $1;
 509                   struct type *range_type;
 510
 511                   while (!done)
 512                     switch (pop_type ())
 513                       {
 514                       case tp_end:
 515                         done = 1;
 516                         break;
 517                       case tp_pointer:
 518                         follow_type = lookup_pointer_type (follow_type);
 519                         break;
 520                       case tp_reference:
 521                         follow_type = lookup_reference_type (follow_type);
 522                         break;
 523                       case tp_array:
 524                         array_size = pop_type_int ();
 525                         if (array_size != -1)
 526                           {
 527                             range_type =
 528                               create_range_type ((struct type *) NULL,
 529                                                  builtin_type_f_integer, 0,
 530                                                  array_size - 1);
 531                             follow_type =
 532                               create_array_type ((struct type *) NULL,
 533                                                  follow_type, range_type);
 534                           }
 535                         else
 536                           follow_type = lookup_pointer_type (follow_type);
 537                         break;
 538                       case tp_function:
 539                         follow_type = lookup_function_type (follow_type);
 540                         break;
 541                       }
 542                   $$ = follow_type;
 543                 }
 544         ;
 545
 546 abs_decl:       '*'
 547                         { push_type (tp_pointer); $$ = 0; }
 548         |       '*' abs_decl
 549                         { push_type (tp_pointer); $$ = $2; }
 550         |       '&'
 551                         { push_type (tp_reference); $$ = 0; }
 552         |       '&' abs_decl
 553                         { push_type (tp_reference); $$ = $2; }
 554         |       direct_abs_decl
 555         ;
 556
 557 direct_abs_decl: '(' abs_decl ')'
 558                         { $$ = $2; }
 559         |       direct_abs_decl func_mod
 560                         { push_type (tp_function); }
 561         |       func_mod
 562                         { push_type (tp_function); }
 563         ;
 564
 565 func_mod:       '(' ')'
 566                         { $$ = 0; }
 567         |       '(' nonempty_typelist ')'
 568                         { free ((PTR)$2); $$ = 0; }
 569         ;
 570
 571 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 572         :       TYPENAME
 573                         { $$ = $1.type; }
 574         |       INT_KEYWORD
 575                         { $$ = builtin_type_f_integer; }
 576         |       INT_S2_KEYWORD
 577                         { $$ = builtin_type_f_integer_s2; }
 578         |       CHARACTER
 579                         { $$ = builtin_type_f_character; }
 580         |       LOGICAL_KEYWORD
 581                         { $$ = builtin_type_f_logical;}
 582         |       LOGICAL_S2_KEYWORD
 583                         { $$ = builtin_type_f_logical_s2;}
 584         |       LOGICAL_S1_KEYWORD
 585                         { $$ = builtin_type_f_logical_s1;}
 586         |       REAL_KEYWORD
 587                         { $$ = builtin_type_f_real;}
 588         |       REAL_S8_KEYWORD
 589                         { $$ = builtin_type_f_real_s8;}
 590         |       REAL_S16_KEYWORD
 591                         { $$ = builtin_type_f_real_s16;}
 592         |       COMPLEX_S8_KEYWORD
 593                         { $$ = builtin_type_f_complex_s8;}
 594         |       COMPLEX_S16_KEYWORD
 595                         { $$ = builtin_type_f_complex_s16;}
 596         |       COMPLEX_S32_KEYWORD
 597                         { $$ = builtin_type_f_complex_s32;}
 598         ;
 599
 600 typename:       TYPENAME
 601         ;
 602
 603 nonempty_typelist
 604         :       type
 605                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 606                   $<ivec>$[0] = 1;      /* Number of types in vector */
 607                   $$[1] = $1;
 608                 }
 609         |       nonempty_typelist ',' type
 610                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 611                   $$ = (struct type **) realloc ((char *) $1, len);
 612                   $$[$<ivec>$[0]] = $3;
 613                 }
 614         ;
 615
 616 name    :       NAME
 617                         { $$ = $1.stoken; }
 618         |       TYPENAME
 619                         { $$ = $1.stoken; }
 620         |       NAME_OR_INT
 621                         { $$ = $1.stoken; }
 622         ;
 623
 624 name_not_typename :     NAME
 625 /* These would be useful if name_not_typename was useful, but it is just
 626    a fake for "variable", so these cause reduce/reduce conflicts because
 627    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 628    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 629    context where only a name could occur, this might be useful.
 630         |       NAME_OR_INT
 631    */
 632         ;
 633
 634 %%
 635
 636 /* Take care of parsing a number (anything that starts with a digit).
 637    Set yylval and return the token type; update lexptr.
 638    LEN is the number of characters in it.  */
 639
 640 /*** Needs some error checking for the float case ***/
 641
 642 static int
 643 parse_number (p, len, parsed_float, putithere)
 644      register char *p;
 645      register int len;
 646      int parsed_float;
 647      YYSTYPE *putithere;
 648 {
 649   register LONGEST n = 0;
 650   register LONGEST prevn = 0;
 651   register int i;
 652   register int c;
 653   register int base = input_radix;
 654   int unsigned_p = 0;
 655   int long_p = 0;
 656   unsigned LONGEST high_bit;
 657   struct type *signed_type;
 658   struct type *unsigned_type;
 659
 660   if (parsed_float)
 661     {
 662       /* It's a float since it contains a point or an exponent.  */
 663       /* [dD] is not understood as an exponent by atof, change it to 'e'.  */
 664       char *tmp, *tmp2;
 665
 666       tmp = strsave (p);
 667       for (tmp2 = tmp; *tmp2; ++tmp2)
 668         if (*tmp2 == 'd' || *tmp2 == 'D')
 669           *tmp2 = 'e';
 670       putithere->dval = atof (tmp);
 671       free (tmp);
 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
 935  retry:
 936
 937   tokstart = lexptr;
 938
 939   /* First of all, let us make sure we are not dealing with the
 940      special tokens .true. and .false. which evaluate to 1 and 0.  */
 941
 942   if (*lexptr == '.')
 943     {
 944       for (i = 0; boolean_values[i].name != NULL; i++)
 945         {
 946           if STREQN (tokstart, boolean_values[i].name,
 947                     strlen (boolean_values[i].name))
 948             {
 949               lexptr += strlen (boolean_values[i].name);
 950               yylval.lval = boolean_values[i].value;
 951               return BOOLEAN_LITERAL;
 952             }
 953         }
 954     }
 955
 956   /* See if it is a special .foo. operator */
 957
 958   for (i = 0; dot_ops[i].operator != NULL; i++)
 959     if (STREQN (tokstart, dot_ops[i].operator, strlen (dot_ops[i].operator)))
 960       {
 961         lexptr += strlen (dot_ops[i].operator);
 962         yylval.opcode = dot_ops[i].opcode;
 963         return dot_ops[i].token;
 964       }
 965
 966   switch (c = *tokstart)
 967     {
 968     case 0:
 969       return 0;
 970
 971     case ' ':
 972     case '\t':
 973     case '\n':
 974       lexptr++;
 975       goto retry;
 976
 977     case '\'':
 978       token = match_string_literal ();
 979       if (token != 0)
 980         return (token);
 981       break;
 982
 983     case '(':
 984       paren_depth++;
 985       lexptr++;
 986       return c;
 987
 988     case ')':
 989       if (paren_depth == 0)
 990         return 0;
 991       paren_depth--;
 992       lexptr++;
 993       return c;
 994
 995     case ',':
 996       if (comma_terminates && paren_depth == 0)
 997         return 0;
 998       lexptr++;
 999       return c;
1000
1001     case '.':
1002       /* Might be a floating point number.  */
1003       if (lexptr[1] < '0' || lexptr[1] > '9')
1004         goto symbol;            /* Nope, must be a symbol. */
1005       /* FALL THRU into number case.  */
1006
1007     case '0':
1008     case '1':
1009     case '2':
1010     case '3':
1011     case '4':
1012     case '5':
1013     case '6':
1014     case '7':
1015     case '8':
1016     case '9':
1017       {
1018         /* It's a number.  */
1019         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1020         register char *p = tokstart;
1021         int hex = input_radix > 10;
1022
1023         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1024           {
1025             p += 2;
1026             hex = 1;
1027           }
1028         else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D'))
1029           {
1030             p += 2;
1031             hex = 0;
1032           }
1033
1034         for (;; ++p)
1035           {
1036             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1037               got_dot = got_e = 1;
1038             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1039               got_dot = got_d = 1;
1040             else if (!hex && !got_dot && *p == '.')
1041               got_dot = 1;
1042             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1043                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1044                      && (*p == '-' || *p == '+'))
1045               /* This is the sign of the exponent, not the end of the
1046                  number.  */
1047               continue;
1048             /* We will take any letters or digits.  parse_number will
1049                complain if past the radix, or if L or U are not final.  */
1050             else if ((*p < '0' || *p > '9')
1051                      && ((*p < 'a' || *p > 'z')
1052                          && (*p < 'A' || *p > 'Z')))
1053               break;
1054           }
1055         toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d,
1056                                 &yylval);
1057         if (toktype == ERROR)
1058           {
1059             char *err_copy = (char *) alloca (p - tokstart + 1);
1060
1061             memcpy (err_copy, tokstart, p - tokstart);
1062             err_copy[p - tokstart] = 0;
1063             error ("Invalid number \"%s\".", err_copy);
1064           }
1065         lexptr = p;
1066         return toktype;
1067       }
1068
1069     case '+':
1070     case '-':
1071     case '*':
1072     case '/':
1073     case '%':
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     symbol:
1090       lexptr++;
1091       return c;
1092     }
1093
1094   if (!(c == '_' || c == '$'
1095         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1096     /* We must have come across a bad character (e.g. ';').  */
1097     error ("Invalid character '%c' in expression.", c);
1098
1099   namelen = 0;
1100   for (c = tokstart[namelen];
1101        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1102         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1103        c = tokstart[++namelen]);
1104
1105   /* The token "if" terminates the expression and is NOT
1106      removed from the input stream.  */
1107
1108   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1109     return 0;
1110
1111   lexptr += namelen;
1112
1113   /* Handle the tokens $digits; also $ (short for $0) and $$ (short for $$1)
1114      and $$digits (equivalent to $<-digits> if you could type that).
1115      Make token type LAST, and put the number (the digits) in yylval.  */
1116
1117   if (*tokstart == '$')
1118     {
1119       register int negate = 0;
1120
1121       c = 1;
1122       /* Double dollar means negate the number and add -1 as well.
1123          Thus $$ alone means -1.  */
1124       if (namelen >= 2 && tokstart[1] == '$')
1125         {
1126           negate = 1;
1127           c = 2;
1128         }
1129       if (c == namelen)
1130         {
1131           /* Just dollars (one or two) */
1132           yylval.lval = - negate;
1133           return LAST;
1134         }
1135       /* Is the rest of the token digits?  */
1136       for (; c < namelen; c++)
1137         if (!(tokstart[c] >= '0' && tokstart[c] <= '9'))
1138           break;
1139       if (c == namelen)
1140         {
1141           yylval.lval = atoi (tokstart + 1 + negate);
1142           if (negate)
1143             yylval.lval = - yylval.lval;
1144           return LAST;
1145         }
1146     }
1147
1148   /* Handle tokens that refer to machine registers:
1149      $ followed by a register name.  */
1150
1151   if (*tokstart == '$') {
1152     for (c = 0; c < NUM_REGS; c++)
1153       if (namelen - 1 == strlen (reg_names[c])
1154           && STREQN (tokstart + 1, reg_names[c], namelen - 1))
1155         {
1156           yylval.lval = c;
1157           return REGNAME;
1158         }
1159     for (c = 0; c < num_std_regs; c++)
1160       if (namelen - 1 == strlen (std_regs[c].name)
1161           && STREQN (tokstart + 1, std_regs[c].name, namelen - 1))
1162         {
1163           yylval.lval = std_regs[c].regnum;
1164           return REGNAME;
1165         }
1166   }
1167   /* Catch specific keywords.  */
1168
1169   for (i = 0; f77_keywords[i].operator != NULL; i++)
1170     if (STREQN(tokstart, f77_keywords[i].operator,
1171                strlen(f77_keywords[i].operator)))
1172       {
1173         /*      lexptr += strlen(f77_keywords[i].operator); */
1174         yylval.opcode = f77_keywords[i].opcode;
1175         return f77_keywords[i].token;
1176       }
1177
1178   yylval.sval.ptr = tokstart;
1179   yylval.sval.length = namelen;
1180
1181   /* Any other names starting in $ are debugger internal variables.  */
1182
1183   if (*tokstart == '$')
1184     {
1185       yylval.ivar =  lookup_internalvar (copy_name (yylval.sval) + 1);
1186       return VARIABLE;
1187     }
1188
1189   /* Use token-type TYPENAME for symbols that happen to be defined
1190      currently as names of types; NAME for other symbols.
1191      The caller is not constrained to care about the distinction.  */
1192   {
1193     char *tmp = copy_name (yylval.sval);
1194     struct symbol *sym;
1195     int is_a_field_of_this = 0;
1196     int hextype;
1197
1198     sym = lookup_symbol (tmp, expression_context_block,
1199                          VAR_NAMESPACE,
1200                          current_language->la_language == language_cplus
1201                          ? &is_a_field_of_this : NULL,
1202                          NULL);
1203     if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1204       {
1205         yylval.tsym.type = SYMBOL_TYPE (sym);
1206         return TYPENAME;
1207       }
1208     if ((yylval.tsym.type = lookup_primitive_typename (tmp)) != 0)
1209       return TYPENAME;
1210
1211     /* Input names that aren't symbols but ARE valid hex numbers,
1212        when the input radix permits them, can be names or numbers
1213        depending on the parse.  Note we support radixes > 16 here.  */
1214     if (!sym
1215         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1216             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1217       {
1218         YYSTYPE newlval;        /* Its value is ignored.  */
1219         hextype = parse_number (tokstart, namelen, 0, &newlval);
1220         if (hextype == INT)
1221           {
1222             yylval.ssym.sym = sym;
1223             yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1224             return NAME_OR_INT;
1225           }
1226       }
1227
1228     /* Any other kind of symbol */
1229     yylval.ssym.sym = sym;
1230     yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1231     return NAME;
1232   }
1233 }
1234
1235 void
1236 yyerror (msg)
1237      char *msg;
1238 {
1239   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1240 }