gdb/m2-exp.y

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