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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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     DOUBLEST 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> CHARACTER
 190
 191 %token <voidval> 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     :       VARIABLE
 416         ;
 417
 418 exp     :       SIZEOF '(' type ')'     %prec UNARY
 419                         { write_exp_elt_opcode (OP_LONG);
 420                           write_exp_elt_type (builtin_type_f_integer);
 421                           CHECK_TYPEDEF ($3);
 422                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 423                           write_exp_elt_opcode (OP_LONG); }
 424         ;
 425
 426 exp     :       BOOLEAN_LITERAL
 427                         { write_exp_elt_opcode (OP_BOOL);
 428                           write_exp_elt_longcst ((LONGEST) $1);
 429                           write_exp_elt_opcode (OP_BOOL);
 430                         }
 431         ;
 432
 433 exp     :       STRING_LITERAL
 434                         {
 435                           write_exp_elt_opcode (OP_STRING);
 436                           write_exp_string ($1);
 437                           write_exp_elt_opcode (OP_STRING);
 438                         }
 439         ;
 440
 441 variable:       name_not_typename
 442                         { struct symbol *sym = $1.sym;
 443
 444                           if (sym)
 445                             {
 446                               if (symbol_read_needs_frame (sym))
 447                                 {
 448                                   if (innermost_block == 0 ||
 449                                       contained_in (block_found,
 450                                                     innermost_block))
 451                                     innermost_block = block_found;
 452                                 }
 453                               write_exp_elt_opcode (OP_VAR_VALUE);
 454                               /* We want to use the selected frame, not
 455                                  another more inner frame which happens to
 456                                  be in the same block.  */
 457                               write_exp_elt_block (NULL);
 458                               write_exp_elt_sym (sym);
 459                               write_exp_elt_opcode (OP_VAR_VALUE);
 460                               break;
 461                             }
 462                           else
 463                             {
 464                               struct minimal_symbol *msymbol;
 465                               register char *arg = copy_name ($1.stoken);
 466
 467                               msymbol =
 468                                 lookup_minimal_symbol (arg, NULL, NULL);
 469                               if (msymbol != NULL)
 470                                 {
 471                                   write_exp_msymbol (msymbol,
 472                                                      lookup_function_type (builtin_type_int),
 473                                                      builtin_type_int);
 474                                 }
 475                               else if (!have_full_symbols () && !have_partial_symbols ())
 476                                 error ("No symbol table is loaded.  Use the \"file\" command.");
 477                               else
 478                                 error ("No symbol \"%s\" in current context.",
 479                                        copy_name ($1.stoken));
 480                             }
 481                         }
 482         ;
 483
 484
 485 type    :       ptype
 486         ;
 487
 488 ptype   :       typebase
 489         |       typebase abs_decl
 490                 {
 491                   /* This is where the interesting stuff happens.  */
 492                   int done = 0;
 493                   int array_size;
 494                   struct type *follow_type = $1;
 495                   struct type *range_type;
 496
 497                   while (!done)
 498                     switch (pop_type ())
 499                       {
 500                       case tp_end:
 501                         done = 1;
 502                         break;
 503                       case tp_pointer:
 504                         follow_type = lookup_pointer_type (follow_type);
 505                         break;
 506                       case tp_reference:
 507                         follow_type = lookup_reference_type (follow_type);
 508                         break;
 509                       case tp_array:
 510                         array_size = pop_type_int ();
 511                         if (array_size != -1)
 512                           {
 513                             range_type =
 514                               create_range_type ((struct type *) NULL,
 515                                                  builtin_type_f_integer, 0,
 516                                                  array_size - 1);
 517                             follow_type =
 518                               create_array_type ((struct type *) NULL,
 519                                                  follow_type, range_type);
 520                           }
 521                         else
 522                           follow_type = lookup_pointer_type (follow_type);
 523                         break;
 524                       case tp_function:
 525                         follow_type = lookup_function_type (follow_type);
 526                         break;
 527                       }
 528                   $$ = follow_type;
 529                 }
 530         ;
 531
 532 abs_decl:       '*'
 533                         { push_type (tp_pointer); $$ = 0; }
 534         |       '*' abs_decl
 535                         { push_type (tp_pointer); $$ = $2; }
 536         |       '&'
 537                         { push_type (tp_reference); $$ = 0; }
 538         |       '&' abs_decl
 539                         { push_type (tp_reference); $$ = $2; }
 540         |       direct_abs_decl
 541         ;
 542
 543 direct_abs_decl: '(' abs_decl ')'
 544                         { $$ = $2; }
 545         |       direct_abs_decl func_mod
 546                         { push_type (tp_function); }
 547         |       func_mod
 548                         { push_type (tp_function); }
 549         ;
 550
 551 func_mod:       '(' ')'
 552                         { $$ = 0; }
 553         |       '(' nonempty_typelist ')'
 554                         { free ((PTR)$2); $$ = 0; }
 555         ;
 556
 557 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 558         :       TYPENAME
 559                         { $$ = $1.type; }
 560         |       INT_KEYWORD
 561                         { $$ = builtin_type_f_integer; }
 562         |       INT_S2_KEYWORD
 563                         { $$ = builtin_type_f_integer_s2; }
 564         |       CHARACTER
 565                         { $$ = builtin_type_f_character; }
 566         |       LOGICAL_KEYWORD
 567                         { $$ = builtin_type_f_logical;}
 568         |       LOGICAL_S2_KEYWORD
 569                         { $$ = builtin_type_f_logical_s2;}
 570         |       LOGICAL_S1_KEYWORD
 571                         { $$ = builtin_type_f_logical_s1;}
 572         |       REAL_KEYWORD
 573                         { $$ = builtin_type_f_real;}
 574         |       REAL_S8_KEYWORD
 575                         { $$ = builtin_type_f_real_s8;}
 576         |       REAL_S16_KEYWORD
 577                         { $$ = builtin_type_f_real_s16;}
 578         |       COMPLEX_S8_KEYWORD
 579                         { $$ = builtin_type_f_complex_s8;}
 580         |       COMPLEX_S16_KEYWORD
 581                         { $$ = builtin_type_f_complex_s16;}
 582         |       COMPLEX_S32_KEYWORD
 583                         { $$ = builtin_type_f_complex_s32;}
 584         ;
 585
 586 typename:       TYPENAME
 587         ;
 588
 589 nonempty_typelist
 590         :       type
 591                 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
 592                   $<ivec>$[0] = 1;      /* Number of types in vector */
 593                   $$[1] = $1;
 594                 }
 595         |       nonempty_typelist ',' type
 596                 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
 597                   $$ = (struct type **) realloc ((char *) $1, len);
 598                   $$[$<ivec>$[0]] = $3;
 599                 }
 600         ;
 601
 602 name    :       NAME
 603                         { $$ = $1.stoken; }
 604         |       TYPENAME
 605                         { $$ = $1.stoken; }
 606         |       NAME_OR_INT
 607                         { $$ = $1.stoken; }
 608         ;
 609
 610 name_not_typename :     NAME
 611 /* These would be useful if name_not_typename was useful, but it is just
 612    a fake for "variable", so these cause reduce/reduce conflicts because
 613    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 614    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 615    context where only a name could occur, this might be useful.
 616         |       NAME_OR_INT
 617    */
 618         ;
 619
 620 %%
 621
 622 /* Take care of parsing a number (anything that starts with a digit).
 623    Set yylval and return the token type; update lexptr.
 624    LEN is the number of characters in it.  */
 625
 626 /*** Needs some error checking for the float case ***/
 627
 628 static int
 629 parse_number (p, len, parsed_float, putithere)
 630      register char *p;
 631      register int len;
 632      int parsed_float;
 633      YYSTYPE *putithere;
 634 {
 635   register LONGEST n = 0;
 636   register LONGEST prevn = 0;
 637   register int i;
 638   register int c;
 639   register int base = input_radix;
 640   int unsigned_p = 0;
 641   int long_p = 0;
 642   unsigned LONGEST high_bit;
 643   struct type *signed_type;
 644   struct type *unsigned_type;
 645
 646   if (parsed_float)
 647     {
 648       /* It's a float since it contains a point or an exponent.  */
 649       /* [dD] is not understood as an exponent by atof, change it to 'e'.  */
 650       char *tmp, *tmp2;
 651
 652       tmp = strsave (p);
 653       for (tmp2 = tmp; *tmp2; ++tmp2)
 654         if (*tmp2 == 'd' || *tmp2 == 'D')
 655           *tmp2 = 'e';
 656       putithere->dval = atof (tmp);
 657       free (tmp);
 658       return FLOAT;
 659     }
 660
 661   /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
 662   if (p[0] == '0')
 663     switch (p[1])
 664       {
 665       case 'x':
 666       case 'X':
 667         if (len >= 3)
 668           {
 669             p += 2;
 670             base = 16;
 671             len -= 2;
 672           }
 673         break;
 674
 675       case 't':
 676       case 'T':
 677       case 'd':
 678       case 'D':
 679         if (len >= 3)
 680           {
 681             p += 2;
 682             base = 10;
 683             len -= 2;
 684           }
 685         break;
 686
 687       default:
 688         base = 8;
 689         break;
 690       }
 691
 692   while (len-- > 0)
 693     {
 694       c = *p++;
 695       if (c >= 'A' && c <= 'Z')
 696         c += 'a' - 'A';
 697       if (c != 'l' && c != 'u')
 698         n *= base;
 699       if (c >= '0' && c <= '9')
 700         n += i = c - '0';
 701       else
 702         {
 703           if (base > 10 && c >= 'a' && c <= 'f')
 704             n += i = c - 'a' + 10;
 705           else if (len == 0 && c == 'l')
 706             long_p = 1;
 707           else if (len == 0 && c == 'u')
 708             unsigned_p = 1;
 709           else
 710             return ERROR;       /* Char not a digit */
 711         }
 712       if (i >= base)
 713         return ERROR;           /* Invalid digit in this base */
 714
 715       /* Portably test for overflow (only works for nonzero values, so make
 716          a second check for zero).  */
 717       if ((prevn >= n) && n != 0)
 718         unsigned_p=1;           /* Try something unsigned */
 719       /* If range checking enabled, portably test for unsigned overflow.  */
 720       if (RANGE_CHECK && n != 0)
 721         {
 722           if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
 723             range_error("Overflow on numeric constant.");
 724         }
 725       prevn = n;
 726     }
 727
 728   /* If the number is too big to be an int, or it's got an l suffix
 729      then it's a long.  Work out if this has to be a long by
 730      shifting right and and seeing if anything remains, and the
 731      target int size is different to the target long size.
 732
 733      In the expression below, we could have tested
 734      (n >> TARGET_INT_BIT)
 735      to see if it was zero,
 736      but too many compilers warn about that, when ints and longs
 737      are the same size.  So we shift it twice, with fewer bits
 738      each time, for the same result.  */
 739
 740   if ((TARGET_INT_BIT != TARGET_LONG_BIT
 741        && ((n >> 2) >> (TARGET_INT_BIT-2)))   /* Avoid shift warning */
 742       || long_p)
 743     {
 744       high_bit = ((unsigned LONGEST)1) << (TARGET_LONG_BIT-1);
 745       unsigned_type = builtin_type_unsigned_long;
 746       signed_type = builtin_type_long;
 747     }
 748   else
 749     {
 750       high_bit = ((unsigned LONGEST)1) << (TARGET_INT_BIT-1);
 751       unsigned_type = builtin_type_unsigned_int;
 752       signed_type = builtin_type_int;
 753     }
 754
 755   putithere->typed_val.val = n;
 756
 757   /* If the high bit of the worked out type is set then this number
 758      has to be unsigned. */
 759
 760   if (unsigned_p || (n & high_bit))
 761     putithere->typed_val.type = unsigned_type;
 762   else
 763     putithere->typed_val.type = signed_type;
 764
 765   return INT;
 766 }
 767
 768 struct token
 769 {
 770   char *operator;
 771   int token;
 772   enum exp_opcode opcode;
 773 };
 774
 775 static const struct token dot_ops[] =
 776 {
 777   { ".and.", BOOL_AND, BINOP_END },
 778   { ".AND.", BOOL_AND, BINOP_END },
 779   { ".or.", BOOL_OR, BINOP_END },
 780   { ".OR.", BOOL_OR, BINOP_END },
 781   { ".not.", BOOL_NOT, BINOP_END },
 782   { ".NOT.", BOOL_NOT, BINOP_END },
 783   { ".eq.", EQUAL, BINOP_END },
 784   { ".EQ.", EQUAL, BINOP_END },
 785   { ".eqv.", EQUAL, BINOP_END },
 786   { ".NEQV.", NOTEQUAL, BINOP_END },
 787   { ".neqv.", NOTEQUAL, BINOP_END },
 788   { ".EQV.", EQUAL, BINOP_END },
 789   { ".ne.", NOTEQUAL, BINOP_END },
 790   { ".NE.", NOTEQUAL, BINOP_END },
 791   { ".le.", LEQ, BINOP_END },
 792   { ".LE.", LEQ, BINOP_END },
 793   { ".ge.", GEQ, BINOP_END },
 794   { ".GE.", GEQ, BINOP_END },
 795   { ".gt.", GREATERTHAN, BINOP_END },
 796   { ".GT.", GREATERTHAN, BINOP_END },
 797   { ".lt.", LESSTHAN, BINOP_END },
 798   { ".LT.", LESSTHAN, BINOP_END },
 799   { NULL, 0, 0 }
 800 };
 801
 802 struct f77_boolean_val
 803 {
 804   char *name;
 805   int value;
 806 };
 807
 808 static const struct f77_boolean_val boolean_values[]  =
 809 {
 810   { ".true.", 1 },
 811   { ".TRUE.", 1 },
 812   { ".false.", 0 },
 813   { ".FALSE.", 0 },
 814   { NULL, 0 }
 815 };
 816
 817 static const struct token f77_keywords[] =
 818 {
 819   { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END },
 820   { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END },
 821   { "character", CHARACTER, BINOP_END },
 822   { "integer_2", INT_S2_KEYWORD, BINOP_END },
 823   { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END },
 824   { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END },
 825   { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END },
 826   { "integer", INT_KEYWORD, BINOP_END },
 827   { "logical", LOGICAL_KEYWORD, BINOP_END },
 828   { "real_16", REAL_S16_KEYWORD, BINOP_END },
 829   { "complex", COMPLEX_S8_KEYWORD, BINOP_END },
 830   { "sizeof", SIZEOF, BINOP_END },
 831   { "real_8", REAL_S8_KEYWORD, BINOP_END },
 832   { "real", REAL_KEYWORD, BINOP_END },
 833   { NULL, 0, 0 }
 834 };
 835
 836 /* Implementation of a dynamically expandable buffer for processing input
 837    characters acquired through lexptr and building a value to return in
 838    yylval. Ripped off from ch-exp.y */
 839
 840 static char *tempbuf;           /* Current buffer contents */
 841 static int tempbufsize;         /* Size of allocated buffer */
 842 static int tempbufindex;        /* Current index into buffer */
 843
 844 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
 845
 846 #define CHECKBUF(size) \
 847   do { \
 848     if (tempbufindex + (size) >= tempbufsize) \
 849       { \
 850         growbuf_by_size (size); \
 851       } \
 852   } while (0);
 853
 854
 855 /* Grow the static temp buffer if necessary, including allocating the first one
 856    on demand. */
 857
 858 static void
 859 growbuf_by_size (count)
 860      int count;
 861 {
 862   int growby;
 863
 864   growby = max (count, GROWBY_MIN_SIZE);
 865   tempbufsize += growby;
 866   if (tempbuf == NULL)
 867     tempbuf = (char *) malloc (tempbufsize);
 868   else
 869     tempbuf = (char *) realloc (tempbuf, tempbufsize);
 870 }
 871
 872 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
 873    string-literals.
 874
 875    Recognize a string literal.  A string literal is a nonzero sequence
 876    of characters enclosed in matching single quotes, except that
 877    a single character inside single quotes is a character literal, which
 878    we reject as a string literal.  To embed the terminator character inside
 879    a string, it is simply doubled (I.E. 'this''is''one''string') */
 880
 881 static int
 882 match_string_literal ()
 883 {
 884   char *tokptr = lexptr;
 885
 886   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
 887     {
 888       CHECKBUF (1);
 889       if (*tokptr == *lexptr)
 890         {
 891           if (*(tokptr + 1) == *lexptr)
 892             tokptr++;
 893           else
 894             break;
 895         }
 896       tempbuf[tempbufindex++] = *tokptr;
 897     }
 898   if (*tokptr == '\0'                                   /* no terminator */
 899       || tempbufindex == 0)                             /* no string */
 900     return 0;
 901   else
 902     {
 903       tempbuf[tempbufindex] = '\0';
 904       yylval.sval.ptr = tempbuf;
 905       yylval.sval.length = tempbufindex;
 906       lexptr = ++tokptr;
 907       return STRING_LITERAL;
 908     }
 909 }
 910
 911 /* Read one token, getting characters through lexptr.  */
 912
 913 static int
 914 yylex ()
 915 {
 916   int c;
 917   int namelen;
 918   unsigned int i,token;
 919   char *tokstart;
 920
 921  retry:
 922
 923   tokstart = lexptr;
 924
 925   /* First of all, let us make sure we are not dealing with the
 926      special tokens .true. and .false. which evaluate to 1 and 0.  */
 927
 928   if (*lexptr == '.')
 929     {
 930       for (i = 0; boolean_values[i].name != NULL; i++)
 931         {
 932           if STREQN (tokstart, boolean_values[i].name,
 933                     strlen (boolean_values[i].name))
 934             {
 935               lexptr += strlen (boolean_values[i].name);
 936               yylval.lval = boolean_values[i].value;
 937               return BOOLEAN_LITERAL;
 938             }
 939         }
 940     }
 941
 942   /* See if it is a special .foo. operator */
 943
 944   for (i = 0; dot_ops[i].operator != NULL; i++)
 945     if (STREQN (tokstart, dot_ops[i].operator, strlen (dot_ops[i].operator)))
 946       {
 947         lexptr += strlen (dot_ops[i].operator);
 948         yylval.opcode = dot_ops[i].opcode;
 949         return dot_ops[i].token;
 950       }
 951
 952   switch (c = *tokstart)
 953     {
 954     case 0:
 955       return 0;
 956
 957     case ' ':
 958     case '\t':
 959     case '\n':
 960       lexptr++;
 961       goto retry;
 962
 963     case '\'':
 964       token = match_string_literal ();
 965       if (token != 0)
 966         return (token);
 967       break;
 968
 969     case '(':
 970       paren_depth++;
 971       lexptr++;
 972       return c;
 973
 974     case ')':
 975       if (paren_depth == 0)
 976         return 0;
 977       paren_depth--;
 978       lexptr++;
 979       return c;
 980
 981     case ',':
 982       if (comma_terminates && paren_depth == 0)
 983         return 0;
 984       lexptr++;
 985       return c;
 986
 987     case '.':
 988       /* Might be a floating point number.  */
 989       if (lexptr[1] < '0' || lexptr[1] > '9')
 990         goto symbol;            /* Nope, must be a symbol. */
 991       /* FALL THRU into number case.  */
 992
 993     case '0':
 994     case '1':
 995     case '2':
 996     case '3':
 997     case '4':
 998     case '5':
 999     case '6':
1000     case '7':
1001     case '8':
1002     case '9':
1003       {
1004         /* It's a number.  */
1005         int got_dot = 0, got_e = 0, got_d = 0, toktype;
1006         register char *p = tokstart;
1007         int hex = input_radix > 10;
1008
1009         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1010           {
1011             p += 2;
1012             hex = 1;
1013           }
1014         else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D'))
1015           {
1016             p += 2;
1017             hex = 0;
1018           }
1019
1020         for (;; ++p)
1021           {
1022             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1023               got_dot = got_e = 1;
1024             else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1025               got_dot = got_d = 1;
1026             else if (!hex && !got_dot && *p == '.')
1027               got_dot = 1;
1028             else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1029                      || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1030                      && (*p == '-' || *p == '+'))
1031               /* This is the sign of the exponent, not the end of the
1032                  number.  */
1033               continue;
1034             /* We will take any letters or digits.  parse_number will
1035                complain if past the radix, or if L or U are not final.  */
1036             else if ((*p < '0' || *p > '9')
1037                      && ((*p < 'a' || *p > 'z')
1038                          && (*p < 'A' || *p > 'Z')))
1039               break;
1040           }
1041         toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d,
1042                                 &yylval);
1043         if (toktype == ERROR)
1044           {
1045             char *err_copy = (char *) alloca (p - tokstart + 1);
1046
1047             memcpy (err_copy, tokstart, p - tokstart);
1048             err_copy[p - tokstart] = 0;
1049             error ("Invalid number \"%s\".", err_copy);
1050           }
1051         lexptr = p;
1052         return toktype;
1053       }
1054
1055     case '+':
1056     case '-':
1057     case '*':
1058     case '/':
1059     case '%':
1060     case '|':
1061     case '&':
1062     case '^':
1063     case '~':
1064     case '!':
1065     case '@':
1066     case '<':
1067     case '>':
1068     case '[':
1069     case ']':
1070     case '?':
1071     case ':':
1072     case '=':
1073     case '{':
1074     case '}':
1075     symbol:
1076       lexptr++;
1077       return c;
1078     }
1079
1080   if (!(c == '_' || c == '$'
1081         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1082     /* We must have come across a bad character (e.g. ';').  */
1083     error ("Invalid character '%c' in expression.", c);
1084
1085   namelen = 0;
1086   for (c = tokstart[namelen];
1087        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1088         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1089        c = tokstart[++namelen]);
1090
1091   /* The token "if" terminates the expression and is NOT
1092      removed from the input stream.  */
1093
1094   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1095     return 0;
1096
1097   lexptr += namelen;
1098
1099   /* Catch specific keywords.  */
1100
1101   for (i = 0; f77_keywords[i].operator != NULL; i++)
1102     if (STREQN(tokstart, f77_keywords[i].operator,
1103                strlen(f77_keywords[i].operator)))
1104       {
1105         /*      lexptr += strlen(f77_keywords[i].operator); */
1106         yylval.opcode = f77_keywords[i].opcode;
1107         return f77_keywords[i].token;
1108       }
1109
1110   yylval.sval.ptr = tokstart;
1111   yylval.sval.length = namelen;
1112
1113   if (*tokstart == '$')
1114     {
1115       write_dollar_variable (yylval.sval);
1116       return VARIABLE;
1117     }
1118
1119   /* Use token-type TYPENAME for symbols that happen to be defined
1120      currently as names of types; NAME for other symbols.
1121      The caller is not constrained to care about the distinction.  */
1122   {
1123     char *tmp = copy_name (yylval.sval);
1124     struct symbol *sym;
1125     int is_a_field_of_this = 0;
1126     int hextype;
1127
1128     sym = lookup_symbol (tmp, expression_context_block,
1129                          VAR_NAMESPACE,
1130                          current_language->la_language == language_cplus
1131                          ? &is_a_field_of_this : NULL,
1132                          NULL);
1133     if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1134       {
1135         yylval.tsym.type = SYMBOL_TYPE (sym);
1136         return TYPENAME;
1137       }
1138     if ((yylval.tsym.type = lookup_primitive_typename (tmp)) != 0)
1139       return TYPENAME;
1140
1141     /* Input names that aren't symbols but ARE valid hex numbers,
1142        when the input radix permits them, can be names or numbers
1143        depending on the parse.  Note we support radixes > 16 here.  */
1144     if (!sym
1145         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1146             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1147       {
1148         YYSTYPE newlval;        /* Its value is ignored.  */
1149         hextype = parse_number (tokstart, namelen, 0, &newlval);
1150         if (hextype == INT)
1151           {
1152             yylval.ssym.sym = sym;
1153             yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1154             return NAME_OR_INT;
1155           }
1156       }
1157
1158     /* Any other kind of symbol */
1159     yylval.ssym.sym = sym;
1160     yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1161     return NAME;
1162   }
1163 }
1164
1165 void
1166 yyerror (msg)
1167      char *msg;
1168 {
1169   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1170 }