gdb/m2-exp.y

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