gdb/m2-exp.y

   1 /* YACC grammar for Modula-2 expressions, for GDB.
   2    Copyright (C) 1986, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1999,
   3    2000, 2007, 2008, 2009 Free Software Foundation, Inc.
   4    Generated from expread.y (now c-exp.y) and contributed by the Department
   5    of Computer Science at the State University of New York at Buffalo, 1991.
   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 3 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, see <http://www.gnu.org/licenses/>.  */
  21
  22 /* Parse a Modula-2 expression from text in a string,
  23    and return the result as a  struct expression  pointer.
  24    That structure contains arithmetic operations in reverse polish,
  25    with constants represented by operations that are followed by special data.
  26    See expression.h for the details of the format.
  27    What is important here is that it can be built up sequentially
  28    during the process of parsing; the lower levels of the tree always
  29    come first in the result.
  30
  31    Note that malloc's and realloc's in this file are transformed to
  32    xmalloc and xrealloc respectively by the same sed command in the
  33    makefile that remaps any other malloc/realloc inserted by the parser
  34    generator.  Doing this with #defines and trying to control the interaction
  35    with include files (<malloc.h> and <stdlib.h> for example) just became
  36    too messy, particularly when such includes can be inserted at random
  37    times by the parser generator. */
  38
  39 %{
  40
  41 #include "defs.h"
  42 #include "gdb_string.h"
  43 #include "expression.h"
  44 #include "language.h"
  45 #include "value.h"
  46 #include "parser-defs.h"
  47 #include "m2-lang.h"
  48 #include "bfd.h" /* Required by objfiles.h.  */
  49 #include "symfile.h" /* Required by objfiles.h.  */
  50 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
  51 #include "block.h"
  52
  53 #define parse_type builtin_type (parse_gdbarch)
  54 #define parse_m2_type builtin_m2_type (parse_gdbarch)
  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 m2_maxdepth
  64 #define yyparse m2_parse
  65 #define yylex   m2_lex
  66 #define yyerror m2_error
  67 #define yylval  m2_lval
  68 #define yychar  m2_char
  69 #define yydebug m2_debug
  70 #define yypact  m2_pact
  71 #define yyr1    m2_r1
  72 #define yyr2    m2_r2
  73 #define yydef   m2_def
  74 #define yychk   m2_chk
  75 #define yypgo   m2_pgo
  76 #define yyact   m2_act
  77 #define yyexca  m2_exca
  78 #define yyerrflag m2_errflag
  79 #define yynerrs m2_nerrs
  80 #define yyps    m2_ps
  81 #define yypv    m2_pv
  82 #define yys     m2_s
  83 #define yy_yys  m2_yys
  84 #define yystate m2_state
  85 #define yytmp   m2_tmp
  86 #define yyv     m2_v
  87 #define yy_yyv  m2_yyv
  88 #define yyval   m2_val
  89 #define yylloc  m2_lloc
  90 #define yyreds  m2_reds         /* With YYDEBUG defined */
  91 #define yytoks  m2_toks         /* With YYDEBUG defined */
  92 #define yyname  m2_name         /* With YYDEBUG defined */
  93 #define yyrule  m2_rule         /* With YYDEBUG defined */
  94 #define yylhs   m2_yylhs
  95 #define yylen   m2_yylen
  96 #define yydefred m2_yydefred
  97 #define yydgoto m2_yydgoto
  98 #define yysindex m2_yysindex
  99 #define yyrindex m2_yyrindex
 100 #define yygindex m2_yygindex
 101 #define yytable  m2_yytable
 102 #define yycheck  m2_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 #if 0
 117 static char *make_qualname (char *, char *);
 118 #endif
 119
 120 static int parse_number (int);
 121
 122 /* The sign of the number being parsed. */
 123 static int number_sign = 1;
 124
 125 /* The block that the module specified by the qualifer on an identifer is
 126    contained in, */
 127 #if 0
 128 static struct block *modblock=0;
 129 #endif
 130
 131 %}
 132
 133 /* Although the yacc "value" of an expression is not used,
 134    since the result is stored in the structure being created,
 135    other node types do have values.  */
 136
 137 %union
 138   {
 139     LONGEST lval;
 140     ULONGEST ulval;
 141     DOUBLEST dval;
 142     struct symbol *sym;
 143     struct type *tval;
 144     struct stoken sval;
 145     int voidval;
 146     struct block *bval;
 147     enum exp_opcode opcode;
 148     struct internalvar *ivar;
 149
 150     struct type **tvec;
 151     int *ivec;
 152   }
 153
 154 %type <voidval> exp type_exp start set
 155 %type <voidval> variable
 156 %type <tval> type
 157 %type <bval> block
 158 %type <sym> fblock
 159
 160 %token <lval> INT HEX ERROR
 161 %token <ulval> UINT M2_TRUE M2_FALSE CHAR
 162 %token <dval> FLOAT
 163
 164 /* Both NAME and TYPENAME tokens represent symbols in the input,
 165    and both convey their data as strings.
 166    But a TYPENAME is a string that happens to be defined as a typedef
 167    or builtin type name (such as int or char)
 168    and a NAME is any other symbol.
 169
 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
 174 %token <sval> NAME BLOCKNAME IDENT VARNAME
 175 %token <sval> TYPENAME
 176
 177 %token SIZE CAP ORD HIGH ABS MIN_FUNC MAX_FUNC FLOAT_FUNC VAL CHR ODD TRUNC
 178 %token TSIZE
 179 %token INC DEC INCL EXCL
 180
 181 /* The GDB scope operator */
 182 %token COLONCOLON
 183
 184 %token <voidval> INTERNAL_VAR
 185
 186 /* M2 tokens */
 187 %left ','
 188 %left ABOVE_COMMA
 189 %nonassoc ASSIGN
 190 %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
 191 %left OROR
 192 %left LOGICAL_AND '&'
 193 %left '@'
 194 %left '+' '-'
 195 %left '*' '/' DIV MOD
 196 %right UNARY
 197 %right '^' DOT '[' '('
 198 %right NOT '~'
 199 %left COLONCOLON QID
 200 /* This is not an actual token ; it is used for precedence.
 201 %right QID
 202 */
 203
 204 \f
 205 %%
 206
 207 start   :       exp
 208         |       type_exp
 209         ;
 210
 211 type_exp:       type
 212                 { write_exp_elt_opcode(OP_TYPE);
 213                   write_exp_elt_type($1);
 214                   write_exp_elt_opcode(OP_TYPE);
 215                 }
 216         ;
 217
 218 /* Expressions */
 219
 220 exp     :       exp '^'   %prec UNARY
 221                         { write_exp_elt_opcode (UNOP_IND); }
 222         ;
 223
 224 exp     :       '-'
 225                         { number_sign = -1; }
 226                 exp    %prec UNARY
 227                         { number_sign = 1;
 228                           write_exp_elt_opcode (UNOP_NEG); }
 229         ;
 230
 231 exp     :       '+' exp    %prec UNARY
 232                 { write_exp_elt_opcode(UNOP_PLUS); }
 233         ;
 234
 235 exp     :       not_exp exp %prec UNARY
 236                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 237         ;
 238
 239 not_exp :       NOT
 240         |       '~'
 241         ;
 242
 243 exp     :       CAP '(' exp ')'
 244                         { write_exp_elt_opcode (UNOP_CAP); }
 245         ;
 246
 247 exp     :       ORD '(' exp ')'
 248                         { write_exp_elt_opcode (UNOP_ORD); }
 249         ;
 250
 251 exp     :       ABS '(' exp ')'
 252                         { write_exp_elt_opcode (UNOP_ABS); }
 253         ;
 254
 255 exp     :       HIGH '(' exp ')'
 256                         { write_exp_elt_opcode (UNOP_HIGH); }
 257         ;
 258
 259 exp     :       MIN_FUNC '(' type ')'
 260                         { write_exp_elt_opcode (UNOP_MIN);
 261                           write_exp_elt_type ($3);
 262                           write_exp_elt_opcode (UNOP_MIN); }
 263         ;
 264
 265 exp     :       MAX_FUNC '(' type ')'
 266                         { write_exp_elt_opcode (UNOP_MAX);
 267                           write_exp_elt_type ($3);
 268                           write_exp_elt_opcode (UNOP_MAX); }
 269         ;
 270
 271 exp     :       FLOAT_FUNC '(' exp ')'
 272                         { write_exp_elt_opcode (UNOP_FLOAT); }
 273         ;
 274
 275 exp     :       VAL '(' type ',' exp ')'
 276                         { write_exp_elt_opcode (BINOP_VAL);
 277                           write_exp_elt_type ($3);
 278                           write_exp_elt_opcode (BINOP_VAL); }
 279         ;
 280
 281 exp     :       CHR '(' exp ')'
 282                         { write_exp_elt_opcode (UNOP_CHR); }
 283         ;
 284
 285 exp     :       ODD '(' exp ')'
 286                         { write_exp_elt_opcode (UNOP_ODD); }
 287         ;
 288
 289 exp     :       TRUNC '(' exp ')'
 290                         { write_exp_elt_opcode (UNOP_TRUNC); }
 291         ;
 292
 293 exp     :       TSIZE '(' exp ')'
 294                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 295         ;
 296
 297 exp     :       SIZE exp       %prec UNARY
 298                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 299         ;
 300
 301
 302 exp     :       INC '(' exp ')'
 303                         { write_exp_elt_opcode(UNOP_PREINCREMENT); }
 304         ;
 305
 306 exp     :       INC '(' exp ',' exp ')'
 307                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 308                           write_exp_elt_opcode(BINOP_ADD);
 309                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 310         ;
 311
 312 exp     :       DEC '(' exp ')'
 313                         { write_exp_elt_opcode(UNOP_PREDECREMENT);}
 314         ;
 315
 316 exp     :       DEC '(' exp ',' exp ')'
 317                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 318                           write_exp_elt_opcode(BINOP_SUB);
 319                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 320         ;
 321
 322 exp     :       exp DOT NAME
 323                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 324                           write_exp_string ($3);
 325                           write_exp_elt_opcode (STRUCTOP_STRUCT); }
 326         ;
 327
 328 exp     :       set
 329         ;
 330
 331 exp     :       exp IN set
 332                         { error("Sets are not implemented.");}
 333         ;
 334
 335 exp     :       INCL '(' exp ',' exp ')'
 336                         { error("Sets are not implemented.");}
 337         ;
 338
 339 exp     :       EXCL '(' exp ',' exp ')'
 340                         { error("Sets are not implemented.");}
 341         ;
 342
 343 set     :       '{' arglist '}'
 344                         { error("Sets are not implemented.");}
 345         |       type '{' arglist '}'
 346                         { error("Sets are not implemented.");}
 347         ;
 348
 349
 350 /* Modula-2 array subscript notation [a,b,c...] */
 351 exp     :       exp '['
 352                         /* This function just saves the number of arguments
 353                            that follow in the list.  It is *not* specific to
 354                            function types */
 355                         { start_arglist(); }
 356                 non_empty_arglist ']'  %prec DOT
 357                         { write_exp_elt_opcode (MULTI_SUBSCRIPT);
 358                           write_exp_elt_longcst ((LONGEST) end_arglist());
 359                           write_exp_elt_opcode (MULTI_SUBSCRIPT); }
 360         ;
 361
 362 exp     :       exp '[' exp ']'
 363                         { write_exp_elt_opcode (BINOP_SUBSCRIPT); }
 364         ;
 365
 366 exp     :       exp '('
 367                         /* This is to save the value of arglist_len
 368                            being accumulated by an outer function call.  */
 369                         { start_arglist (); }
 370                 arglist ')'     %prec DOT
 371                         { write_exp_elt_opcode (OP_FUNCALL);
 372                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 373                           write_exp_elt_opcode (OP_FUNCALL); }
 374         ;
 375
 376 arglist :
 377         ;
 378
 379 arglist :       exp
 380                         { arglist_len = 1; }
 381         ;
 382
 383 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 384                         { arglist_len++; }
 385         ;
 386
 387 non_empty_arglist
 388         :       exp
 389                         { arglist_len = 1; }
 390         ;
 391
 392 non_empty_arglist
 393         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
 394                         { arglist_len++; }
 395         ;
 396
 397 /* GDB construct */
 398 exp     :       '{' type '}' exp  %prec UNARY
 399                         { write_exp_elt_opcode (UNOP_MEMVAL);
 400                           write_exp_elt_type ($2);
 401                           write_exp_elt_opcode (UNOP_MEMVAL); }
 402         ;
 403
 404 exp     :       type '(' exp ')' %prec UNARY
 405                         { write_exp_elt_opcode (UNOP_CAST);
 406                           write_exp_elt_type ($1);
 407                           write_exp_elt_opcode (UNOP_CAST); }
 408         ;
 409
 410 exp     :       '(' exp ')'
 411                         { }
 412         ;
 413
 414 /* Binary operators in order of decreasing precedence.  Note that some
 415    of these operators are overloaded!  (ie. sets) */
 416
 417 /* GDB construct */
 418 exp     :       exp '@' exp
 419                         { write_exp_elt_opcode (BINOP_REPEAT); }
 420         ;
 421
 422 exp     :       exp '*' exp
 423                         { write_exp_elt_opcode (BINOP_MUL); }
 424         ;
 425
 426 exp     :       exp '/' exp
 427                         { write_exp_elt_opcode (BINOP_DIV); }
 428         ;
 429
 430 exp     :       exp DIV exp
 431                         { write_exp_elt_opcode (BINOP_INTDIV); }
 432         ;
 433
 434 exp     :       exp MOD exp
 435                         { write_exp_elt_opcode (BINOP_REM); }
 436         ;
 437
 438 exp     :       exp '+' exp
 439                         { write_exp_elt_opcode (BINOP_ADD); }
 440         ;
 441
 442 exp     :       exp '-' exp
 443                         { write_exp_elt_opcode (BINOP_SUB); }
 444         ;
 445
 446 exp     :       exp '=' exp
 447                         { write_exp_elt_opcode (BINOP_EQUAL); }
 448         ;
 449
 450 exp     :       exp NOTEQUAL exp
 451                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 452         |       exp '#' exp
 453                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 454         ;
 455
 456 exp     :       exp LEQ exp
 457                         { write_exp_elt_opcode (BINOP_LEQ); }
 458         ;
 459
 460 exp     :       exp GEQ exp
 461                         { write_exp_elt_opcode (BINOP_GEQ); }
 462         ;
 463
 464 exp     :       exp '<' exp
 465                         { write_exp_elt_opcode (BINOP_LESS); }
 466         ;
 467
 468 exp     :       exp '>' exp
 469                         { write_exp_elt_opcode (BINOP_GTR); }
 470         ;
 471
 472 exp     :       exp LOGICAL_AND exp
 473                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 474         ;
 475
 476 exp     :       exp OROR exp
 477                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 478         ;
 479
 480 exp     :       exp ASSIGN exp
 481                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 482         ;
 483
 484
 485 /* Constants */
 486
 487 exp     :       M2_TRUE
 488                         { write_exp_elt_opcode (OP_BOOL);
 489                           write_exp_elt_longcst ((LONGEST) $1);
 490                           write_exp_elt_opcode (OP_BOOL); }
 491         ;
 492
 493 exp     :       M2_FALSE
 494                         { write_exp_elt_opcode (OP_BOOL);
 495                           write_exp_elt_longcst ((LONGEST) $1);
 496                           write_exp_elt_opcode (OP_BOOL); }
 497         ;
 498
 499 exp     :       INT
 500                         { write_exp_elt_opcode (OP_LONG);
 501                           write_exp_elt_type (parse_m2_type->builtin_int);
 502                           write_exp_elt_longcst ((LONGEST) $1);
 503                           write_exp_elt_opcode (OP_LONG); }
 504         ;
 505
 506 exp     :       UINT
 507                         {
 508                           write_exp_elt_opcode (OP_LONG);
 509                           write_exp_elt_type (parse_m2_type->builtin_card);
 510                           write_exp_elt_longcst ((LONGEST) $1);
 511                           write_exp_elt_opcode (OP_LONG);
 512                         }
 513         ;
 514
 515 exp     :       CHAR
 516                         { write_exp_elt_opcode (OP_LONG);
 517                           write_exp_elt_type (parse_m2_type->builtin_char);
 518                           write_exp_elt_longcst ((LONGEST) $1);
 519                           write_exp_elt_opcode (OP_LONG); }
 520         ;
 521
 522
 523 exp     :       FLOAT
 524                         { write_exp_elt_opcode (OP_DOUBLE);
 525                           write_exp_elt_type (parse_m2_type->builtin_real);
 526                           write_exp_elt_dblcst ($1);
 527                           write_exp_elt_opcode (OP_DOUBLE); }
 528         ;
 529
 530 exp     :       variable
 531         ;
 532
 533 exp     :       SIZE '(' type ')'       %prec UNARY
 534                         { write_exp_elt_opcode (OP_LONG);
 535                           write_exp_elt_type (parse_type->builtin_int);
 536                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 537                           write_exp_elt_opcode (OP_LONG); }
 538         ;
 539
 540 exp     :       STRING
 541                         { write_exp_elt_opcode (OP_M2_STRING);
 542                           write_exp_string ($1);
 543                           write_exp_elt_opcode (OP_M2_STRING); }
 544         ;
 545
 546 /* This will be used for extensions later.  Like adding modules. */
 547 block   :       fblock
 548                         { $$ = SYMBOL_BLOCK_VALUE($1); }
 549         ;
 550
 551 fblock  :       BLOCKNAME
 552                         { struct symbol *sym
 553                             = lookup_symbol (copy_name ($1), expression_context_block,
 554                                              VAR_DOMAIN, 0);
 555                           $$ = sym;}
 556         ;
 557
 558
 559 /* GDB scope operator */
 560 fblock  :       block COLONCOLON BLOCKNAME
 561                         { struct symbol *tem
 562                             = lookup_symbol (copy_name ($3), $1,
 563                                              VAR_DOMAIN, 0);
 564                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
 565                             error ("No function \"%s\" in specified context.",
 566                                    copy_name ($3));
 567                           $$ = tem;
 568                         }
 569         ;
 570
 571 /* Useful for assigning to PROCEDURE variables */
 572 variable:       fblock
 573                         { write_exp_elt_opcode(OP_VAR_VALUE);
 574                           write_exp_elt_block (NULL);
 575                           write_exp_elt_sym ($1);
 576                           write_exp_elt_opcode (OP_VAR_VALUE); }
 577         ;
 578
 579 /* GDB internal ($foo) variable */
 580 variable:       INTERNAL_VAR
 581         ;
 582
 583 /* GDB scope operator */
 584 variable:       block COLONCOLON NAME
 585                         { struct symbol *sym;
 586                           sym = lookup_symbol (copy_name ($3), $1,
 587                                                VAR_DOMAIN, 0);
 588                           if (sym == 0)
 589                             error ("No symbol \"%s\" in specified context.",
 590                                    copy_name ($3));
 591
 592                           write_exp_elt_opcode (OP_VAR_VALUE);
 593                           /* block_found is set by lookup_symbol.  */
 594                           write_exp_elt_block (block_found);
 595                           write_exp_elt_sym (sym);
 596                           write_exp_elt_opcode (OP_VAR_VALUE); }
 597         ;
 598
 599 /* Base case for variables. */
 600 variable:       NAME
 601                         { struct symbol *sym;
 602                           int is_a_field_of_this;
 603
 604                           sym = lookup_symbol (copy_name ($1),
 605                                                expression_context_block,
 606                                                VAR_DOMAIN,
 607                                                &is_a_field_of_this);
 608                           if (sym)
 609                             {
 610                               if (symbol_read_needs_frame (sym))
 611                                 {
 612                                   if (innermost_block == 0 ||
 613                                       contained_in (block_found,
 614                                                     innermost_block))
 615                                     innermost_block = block_found;
 616                                 }
 617
 618                               write_exp_elt_opcode (OP_VAR_VALUE);
 619                               /* We want to use the selected frame, not
 620                                  another more inner frame which happens to
 621                                  be in the same block.  */
 622                               write_exp_elt_block (NULL);
 623                               write_exp_elt_sym (sym);
 624                               write_exp_elt_opcode (OP_VAR_VALUE);
 625                             }
 626                           else
 627                             {
 628                               struct minimal_symbol *msymbol;
 629                               char *arg = copy_name ($1);
 630
 631                               msymbol =
 632                                 lookup_minimal_symbol (arg, NULL, NULL);
 633                               if (msymbol != NULL)
 634                                 write_exp_msymbol (msymbol);
 635                               else if (!have_full_symbols () && !have_partial_symbols ())
 636                                 error ("No symbol table is loaded.  Use the \"symbol-file\" command.");
 637                               else
 638                                 error ("No symbol \"%s\" in current context.",
 639                                        copy_name ($1));
 640                             }
 641                         }
 642         ;
 643
 644 type
 645         :       TYPENAME
 646                         { $$ = lookup_typename (parse_language, parse_gdbarch,
 647                                                 copy_name ($1),
 648                                                 expression_context_block, 0); }
 649
 650         ;
 651
 652 %%
 653
 654 #if 0  /* FIXME! */
 655 int
 656 overflow(a,b)
 657    long a,b;
 658 {
 659    return (MAX_OF_TYPE(parse_m2_type->builtin_int) - b) < a;
 660 }
 661
 662 int
 663 uoverflow(a,b)
 664    unsigned long a,b;
 665 {
 666    return (MAX_OF_TYPE(parse_m2_type->builtin_card) - b) < a;
 667 }
 668 #endif /* FIXME */
 669
 670 /* Take care of parsing a number (anything that starts with a digit).
 671    Set yylval and return the token type; update lexptr.
 672    LEN is the number of characters in it.  */
 673
 674 /*** Needs some error checking for the float case ***/
 675
 676 static int
 677 parse_number (olen)
 678      int olen;
 679 {
 680   char *p = lexptr;
 681   LONGEST n = 0;
 682   LONGEST prevn = 0;
 683   int c,i,ischar=0;
 684   int base = input_radix;
 685   int len = olen;
 686   int unsigned_p = number_sign == 1 ? 1 : 0;
 687
 688   if(p[len-1] == 'H')
 689   {
 690      base = 16;
 691      len--;
 692   }
 693   else if(p[len-1] == 'C' || p[len-1] == 'B')
 694   {
 695      base = 8;
 696      ischar = p[len-1] == 'C';
 697      len--;
 698   }
 699
 700   /* Scan the number */
 701   for (c = 0; c < len; c++)
 702   {
 703     if (p[c] == '.' && base == 10)
 704       {
 705         /* It's a float since it contains a point.  */
 706         yylval.dval = atof (p);
 707         lexptr += len;
 708         return FLOAT;
 709       }
 710     if (p[c] == '.' && base != 10)
 711        error("Floating point numbers must be base 10.");
 712     if (base == 10 && (p[c] < '0' || p[c] > '9'))
 713        error("Invalid digit \'%c\' in number.",p[c]);
 714  }
 715
 716   while (len-- > 0)
 717     {
 718       c = *p++;
 719       n *= base;
 720       if( base == 8 && (c == '8' || c == '9'))
 721          error("Invalid digit \'%c\' in octal number.",c);
 722       if (c >= '0' && c <= '9')
 723         i = c - '0';
 724       else
 725         {
 726           if (base == 16 && c >= 'A' && c <= 'F')
 727             i = c - 'A' + 10;
 728           else
 729              return ERROR;
 730         }
 731       n+=i;
 732       if(i >= base)
 733          return ERROR;
 734       if(!unsigned_p && number_sign == 1 && (prevn >= n))
 735          unsigned_p=1;          /* Try something unsigned */
 736       /* Don't do the range check if n==i and i==0, since that special
 737          case will give an overflow error. */
 738       if(RANGE_CHECK && n!=i && i)
 739       {
 740          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
 741             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
 742             range_error("Overflow on numeric constant.");
 743       }
 744          prevn=n;
 745     }
 746
 747   lexptr = p;
 748   if(*p == 'B' || *p == 'C' || *p == 'H')
 749      lexptr++;                  /* Advance past B,C or H */
 750
 751   if (ischar)
 752   {
 753      yylval.ulval = n;
 754      return CHAR;
 755   }
 756   else if ( unsigned_p && number_sign == 1)
 757   {
 758      yylval.ulval = n;
 759      return UINT;
 760   }
 761   else if((unsigned_p && (n<0))) {
 762      range_error("Overflow on numeric constant -- number too large.");
 763      /* But, this can return if range_check == range_warn.  */
 764   }
 765   yylval.lval = n;
 766   return INT;
 767 }
 768
 769
 770 /* Some tokens */
 771
 772 static struct
 773 {
 774    char name[2];
 775    int token;
 776 } tokentab2[] =
 777 {
 778     { {'<', '>'},    NOTEQUAL   },
 779     { {':', '='},    ASSIGN     },
 780     { {'<', '='},    LEQ        },
 781     { {'>', '='},    GEQ        },
 782     { {':', ':'},    COLONCOLON },
 783
 784 };
 785
 786 /* Some specific keywords */
 787
 788 struct keyword {
 789    char keyw[10];
 790    int token;
 791 };
 792
 793 static struct keyword keytab[] =
 794 {
 795     {"OR" ,   OROR       },
 796     {"IN",    IN         },/* Note space after IN */
 797     {"AND",   LOGICAL_AND},
 798     {"ABS",   ABS        },
 799     {"CHR",   CHR        },
 800     {"DEC",   DEC        },
 801     {"NOT",   NOT        },
 802     {"DIV",   DIV        },
 803     {"INC",   INC        },
 804     {"MAX",   MAX_FUNC   },
 805     {"MIN",   MIN_FUNC   },
 806     {"MOD",   MOD        },
 807     {"ODD",   ODD        },
 808     {"CAP",   CAP        },
 809     {"ORD",   ORD        },
 810     {"VAL",   VAL        },
 811     {"EXCL",  EXCL       },
 812     {"HIGH",  HIGH       },
 813     {"INCL",  INCL       },
 814     {"SIZE",  SIZE       },
 815     {"FLOAT", FLOAT_FUNC },
 816     {"TRUNC", TRUNC      },
 817     {"TSIZE", SIZE       },
 818 };
 819
 820
 821 /* Read one token, getting characters through lexptr.  */
 822
 823 /* This is where we will check to make sure that the language and the operators used are
 824    compatible  */
 825
 826 static int
 827 yylex ()
 828 {
 829   int c;
 830   int namelen;
 831   int i;
 832   char *tokstart;
 833   char quote;
 834
 835  retry:
 836
 837   prev_lexptr = lexptr;
 838
 839   tokstart = lexptr;
 840
 841
 842   /* See if it is a special token of length 2 */
 843   for( i = 0 ; i < (int) (sizeof tokentab2 / sizeof tokentab2[0]) ; i++)
 844      if (strncmp (tokentab2[i].name, tokstart, 2) == 0)
 845      {
 846         lexptr += 2;
 847         return tokentab2[i].token;
 848      }
 849
 850   switch (c = *tokstart)
 851     {
 852     case 0:
 853       return 0;
 854
 855     case ' ':
 856     case '\t':
 857     case '\n':
 858       lexptr++;
 859       goto retry;
 860
 861     case '(':
 862       paren_depth++;
 863       lexptr++;
 864       return c;
 865
 866     case ')':
 867       if (paren_depth == 0)
 868         return 0;
 869       paren_depth--;
 870       lexptr++;
 871       return c;
 872
 873     case ',':
 874       if (comma_terminates && paren_depth == 0)
 875         return 0;
 876       lexptr++;
 877       return c;
 878
 879     case '.':
 880       /* Might be a floating point number.  */
 881       if (lexptr[1] >= '0' && lexptr[1] <= '9')
 882         break;                  /* Falls into number code.  */
 883       else
 884       {
 885          lexptr++;
 886          return DOT;
 887       }
 888
 889 /* These are character tokens that appear as-is in the YACC grammar */
 890     case '+':
 891     case '-':
 892     case '*':
 893     case '/':
 894     case '^':
 895     case '<':
 896     case '>':
 897     case '[':
 898     case ']':
 899     case '=':
 900     case '{':
 901     case '}':
 902     case '#':
 903     case '@':
 904     case '~':
 905     case '&':
 906       lexptr++;
 907       return c;
 908
 909     case '\'' :
 910     case '"':
 911       quote = c;
 912       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
 913         if (c == '\\')
 914           {
 915             c = tokstart[++namelen];
 916             if (c >= '0' && c <= '9')
 917               {
 918                 c = tokstart[++namelen];
 919                 if (c >= '0' && c <= '9')
 920                   c = tokstart[++namelen];
 921               }
 922           }
 923       if(c != quote)
 924          error("Unterminated string or character constant.");
 925       yylval.sval.ptr = tokstart + 1;
 926       yylval.sval.length = namelen - 1;
 927       lexptr += namelen + 1;
 928
 929       if(namelen == 2)          /* Single character */
 930       {
 931            yylval.ulval = tokstart[1];
 932            return CHAR;
 933       }
 934       else
 935          return STRING;
 936     }
 937
 938   /* Is it a number?  */
 939   /* Note:  We have already dealt with the case of the token '.'.
 940      See case '.' above.  */
 941   if ((c >= '0' && c <= '9'))
 942     {
 943       /* It's a number.  */
 944       int got_dot = 0, got_e = 0;
 945       char *p = tokstart;
 946       int toktype;
 947
 948       for (++p ;; ++p)
 949         {
 950           if (!got_e && (*p == 'e' || *p == 'E'))
 951             got_dot = got_e = 1;
 952           else if (!got_dot && *p == '.')
 953             got_dot = 1;
 954           else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
 955                    && (*p == '-' || *p == '+'))
 956             /* This is the sign of the exponent, not the end of the
 957                number.  */
 958             continue;
 959           else if ((*p < '0' || *p > '9') &&
 960                    (*p < 'A' || *p > 'F') &&
 961                    (*p != 'H'))  /* Modula-2 hexadecimal number */
 962             break;
 963         }
 964         toktype = parse_number (p - tokstart);
 965         if (toktype == ERROR)
 966           {
 967             char *err_copy = (char *) alloca (p - tokstart + 1);
 968
 969             memcpy (err_copy, tokstart, p - tokstart);
 970             err_copy[p - tokstart] = 0;
 971             error ("Invalid number \"%s\".", err_copy);
 972           }
 973         lexptr = p;
 974         return toktype;
 975     }
 976
 977   if (!(c == '_' || c == '$'
 978         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
 979     /* We must have come across a bad character (e.g. ';').  */
 980     error ("Invalid character '%c' in expression.", c);
 981
 982   /* It's a name.  See how long it is.  */
 983   namelen = 0;
 984   for (c = tokstart[namelen];
 985        (c == '_' || c == '$' || (c >= '0' && c <= '9')
 986         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
 987        c = tokstart[++namelen])
 988     ;
 989
 990   /* The token "if" terminates the expression and is NOT
 991      removed from the input stream.  */
 992   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
 993     {
 994       return 0;
 995     }
 996
 997   lexptr += namelen;
 998
 999   /*  Lookup special keywords */
1000   for(i = 0 ; i < (int) (sizeof(keytab) / sizeof(keytab[0])) ; i++)
1001      if (namelen == strlen (keytab[i].keyw)
1002          && strncmp (tokstart, keytab[i].keyw, namelen) == 0)
1003            return keytab[i].token;
1004
1005   yylval.sval.ptr = tokstart;
1006   yylval.sval.length = namelen;
1007
1008   if (*tokstart == '$')
1009     {
1010       write_dollar_variable (yylval.sval);
1011       return INTERNAL_VAR;
1012     }
1013
1014   /* Use token-type BLOCKNAME for symbols that happen to be defined as
1015      functions.  If this is not so, then ...
1016      Use token-type TYPENAME for symbols that happen to be defined
1017      currently as names of types; NAME for other symbols.
1018      The caller is not constrained to care about the distinction.  */
1019  {
1020
1021
1022     char *tmp = copy_name (yylval.sval);
1023     struct symbol *sym;
1024
1025     if (lookup_partial_symtab (tmp))
1026       return BLOCKNAME;
1027     sym = lookup_symbol (tmp, expression_context_block, VAR_DOMAIN, 0);
1028     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1029       return BLOCKNAME;
1030     if (lookup_typename (parse_language, parse_gdbarch,
1031                          copy_name (yylval.sval), expression_context_block, 1))
1032       return TYPENAME;
1033
1034     if(sym)
1035     {
1036       switch(SYMBOL_CLASS (sym))
1037        {
1038        case LOC_STATIC:
1039        case LOC_REGISTER:
1040        case LOC_ARG:
1041        case LOC_REF_ARG:
1042        case LOC_REGPARM_ADDR:
1043        case LOC_LOCAL:
1044        case LOC_CONST:
1045        case LOC_CONST_BYTES:
1046        case LOC_OPTIMIZED_OUT:
1047        case LOC_COMPUTED:
1048           return NAME;
1049
1050        case LOC_TYPEDEF:
1051           return TYPENAME;
1052
1053        case LOC_BLOCK:
1054           return BLOCKNAME;
1055
1056        case LOC_UNDEF:
1057           error("internal:  Undefined class in m2lex()");
1058
1059        case LOC_LABEL:
1060        case LOC_UNRESOLVED:
1061           error("internal:  Unforseen case in m2lex()");
1062
1063        default:
1064           error ("unhandled token in m2lex()");
1065           break;
1066        }
1067     }
1068     else
1069     {
1070        /* Built-in BOOLEAN type.  This is sort of a hack. */
1071        if (strncmp (tokstart, "TRUE", 4) == 0)
1072        {
1073           yylval.ulval = 1;
1074           return M2_TRUE;
1075        }
1076        else if (strncmp (tokstart, "FALSE", 5) == 0)
1077        {
1078           yylval.ulval = 0;
1079           return M2_FALSE;
1080        }
1081     }
1082
1083     /* Must be another type of name... */
1084     return NAME;
1085  }
1086 }
1087
1088 #if 0           /* Unused */
1089 static char *
1090 make_qualname(mod,ident)
1091    char *mod, *ident;
1092 {
1093    char *new = malloc(strlen(mod)+strlen(ident)+2);
1094
1095    strcpy(new,mod);
1096    strcat(new,".");
1097    strcat(new,ident);
1098    return new;
1099 }
1100 #endif  /* 0 */
1101
1102 void
1103 yyerror (msg)
1104      char *msg;
1105 {
1106   if (prev_lexptr)
1107     lexptr = prev_lexptr;
1108
1109   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1110 }