gdb/f-exp.y

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