gdb/m2-exp.y

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