contrib/gdb/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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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 "gdb_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 #define yylhs   m2_yylhs
  90 #define yylen   m2_yylen
  91 #define yydefred m2_yydefred
  92 #define yydgoto m2_yydgoto
  93 #define yysindex m2_yysindex
  94 #define yyrindex m2_yyrindex
  95 #define yygindex m2_yygindex
  96 #define yytable  m2_yytable
  97 #define yycheck  m2_yycheck
  98
  99 #ifndef YYDEBUG
 100 #define YYDEBUG 0               /* Default to no yydebug support */
 101 #endif
 102
 103 int
 104 yyparse PARAMS ((void));
 105
 106 static int
 107 yylex PARAMS ((void));
 108
 109 void
 110 yyerror PARAMS ((char *));
 111
 112 #if 0
 113 static char *
 114 make_qualname PARAMS ((char *, char *));
 115 #endif
 116
 117 static int
 118 parse_number PARAMS ((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 exp     :       '-'
 221                         { number_sign = -1; }
 222                 exp    %prec UNARY
 223                         { number_sign = 1;
 224                           write_exp_elt_opcode (UNOP_NEG); }
 225         ;
 226
 227 exp     :       '+' exp    %prec UNARY
 228                 { write_exp_elt_opcode(UNOP_PLUS); }
 229         ;
 230
 231 exp     :       not_exp exp %prec UNARY
 232                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 233         ;
 234
 235 not_exp :       NOT
 236         |       '~'
 237         ;
 238
 239 exp     :       CAP '(' exp ')'
 240                         { write_exp_elt_opcode (UNOP_CAP); }
 241         ;
 242
 243 exp     :       ORD '(' exp ')'
 244                         { write_exp_elt_opcode (UNOP_ORD); }
 245         ;
 246
 247 exp     :       ABS '(' exp ')'
 248                         { write_exp_elt_opcode (UNOP_ABS); }
 249         ;
 250
 251 exp     :       HIGH '(' exp ')'
 252                         { write_exp_elt_opcode (UNOP_HIGH); }
 253         ;
 254
 255 exp     :       MIN_FUNC '(' type ')'
 256                         { write_exp_elt_opcode (UNOP_MIN);
 257                           write_exp_elt_type ($3);
 258                           write_exp_elt_opcode (UNOP_MIN); }
 259         ;
 260
 261 exp     :       MAX_FUNC '(' type ')'
 262                         { write_exp_elt_opcode (UNOP_MAX);
 263                           write_exp_elt_type ($3);
 264                           write_exp_elt_opcode (UNOP_MIN); }
 265         ;
 266
 267 exp     :       FLOAT_FUNC '(' exp ')'
 268                         { write_exp_elt_opcode (UNOP_FLOAT); }
 269         ;
 270
 271 exp     :       VAL '(' type ',' exp ')'
 272                         { write_exp_elt_opcode (BINOP_VAL);
 273                           write_exp_elt_type ($3);
 274                           write_exp_elt_opcode (BINOP_VAL); }
 275         ;
 276
 277 exp     :       CHR '(' exp ')'
 278                         { write_exp_elt_opcode (UNOP_CHR); }
 279         ;
 280
 281 exp     :       ODD '(' exp ')'
 282                         { write_exp_elt_opcode (UNOP_ODD); }
 283         ;
 284
 285 exp     :       TRUNC '(' exp ')'
 286                         { write_exp_elt_opcode (UNOP_TRUNC); }
 287         ;
 288
 289 exp     :       SIZE exp       %prec UNARY
 290                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 291         ;
 292
 293
 294 exp     :       INC '(' exp ')'
 295                         { write_exp_elt_opcode(UNOP_PREINCREMENT); }
 296         ;
 297
 298 exp     :       INC '(' exp ',' exp ')'
 299                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 300                           write_exp_elt_opcode(BINOP_ADD);
 301                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 302         ;
 303
 304 exp     :       DEC '(' exp ')'
 305                         { write_exp_elt_opcode(UNOP_PREDECREMENT);}
 306         ;
 307
 308 exp     :       DEC '(' exp ',' exp ')'
 309                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 310                           write_exp_elt_opcode(BINOP_SUB);
 311                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 312         ;
 313
 314 exp     :       exp DOT NAME
 315                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 316                           write_exp_string ($3);
 317                           write_exp_elt_opcode (STRUCTOP_STRUCT); }
 318         ;
 319
 320 exp     :       set
 321         ;
 322
 323 exp     :       exp IN set
 324                         { error("Sets are not implemented.");}
 325         ;
 326
 327 exp     :       INCL '(' exp ',' exp ')'
 328                         { error("Sets are not implemented.");}
 329         ;
 330
 331 exp     :       EXCL '(' exp ',' exp ')'
 332                         { error("Sets are not implemented.");}
 333
 334 set     :       '{' arglist '}'
 335                         { error("Sets are not implemented.");}
 336         |       type '{' arglist '}'
 337                         { error("Sets are not implemented.");}
 338         ;
 339
 340
 341 /* Modula-2 array subscript notation [a,b,c...] */
 342 exp     :       exp '['
 343                         /* This function just saves the number of arguments
 344                            that follow in the list.  It is *not* specific to
 345                            function types */
 346                         { start_arglist(); }
 347                 non_empty_arglist ']'  %prec DOT
 348                         { write_exp_elt_opcode (MULTI_SUBSCRIPT);
 349                           write_exp_elt_longcst ((LONGEST) end_arglist());
 350                           write_exp_elt_opcode (MULTI_SUBSCRIPT); }
 351         ;
 352
 353 exp     :       exp '('
 354                         /* This is to save the value of arglist_len
 355                            being accumulated by an outer function call.  */
 356                         { start_arglist (); }
 357                 arglist ')'     %prec DOT
 358                         { write_exp_elt_opcode (OP_FUNCALL);
 359                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 360                           write_exp_elt_opcode (OP_FUNCALL); }
 361         ;
 362
 363 arglist :
 364         ;
 365
 366 arglist :       exp
 367                         { arglist_len = 1; }
 368         ;
 369
 370 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 371                         { arglist_len++; }
 372         ;
 373
 374 non_empty_arglist
 375         :       exp
 376                         { arglist_len = 1; }
 377         ;
 378
 379 non_empty_arglist
 380         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
 381                         { arglist_len++; }
 382         ;
 383
 384 /* GDB construct */
 385 exp     :       '{' type '}' exp  %prec UNARY
 386                         { write_exp_elt_opcode (UNOP_MEMVAL);
 387                           write_exp_elt_type ($2);
 388                           write_exp_elt_opcode (UNOP_MEMVAL); }
 389         ;
 390
 391 exp     :       type '(' exp ')' %prec UNARY
 392                         { write_exp_elt_opcode (UNOP_CAST);
 393                           write_exp_elt_type ($1);
 394                           write_exp_elt_opcode (UNOP_CAST); }
 395         ;
 396
 397 exp     :       '(' exp ')'
 398                         { }
 399         ;
 400
 401 /* Binary operators in order of decreasing precedence.  Note that some
 402    of these operators are overloaded!  (ie. sets) */
 403
 404 /* GDB construct */
 405 exp     :       exp '@' exp
 406                         { write_exp_elt_opcode (BINOP_REPEAT); }
 407         ;
 408
 409 exp     :       exp '*' exp
 410                         { write_exp_elt_opcode (BINOP_MUL); }
 411         ;
 412
 413 exp     :       exp '/' exp
 414                         { write_exp_elt_opcode (BINOP_DIV); }
 415         ;
 416
 417 exp     :       exp DIV exp
 418                         { write_exp_elt_opcode (BINOP_INTDIV); }
 419         ;
 420
 421 exp     :       exp MOD exp
 422                         { write_exp_elt_opcode (BINOP_REM); }
 423         ;
 424
 425 exp     :       exp '+' exp
 426                         { write_exp_elt_opcode (BINOP_ADD); }
 427         ;
 428
 429 exp     :       exp '-' exp
 430                         { write_exp_elt_opcode (BINOP_SUB); }
 431         ;
 432
 433 exp     :       exp '=' exp
 434                         { write_exp_elt_opcode (BINOP_EQUAL); }
 435         ;
 436
 437 exp     :       exp NOTEQUAL exp
 438                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 439         |       exp '#' exp
 440                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 441         ;
 442
 443 exp     :       exp LEQ exp
 444                         { write_exp_elt_opcode (BINOP_LEQ); }
 445         ;
 446
 447 exp     :       exp GEQ exp
 448                         { write_exp_elt_opcode (BINOP_GEQ); }
 449         ;
 450
 451 exp     :       exp '<' exp
 452                         { write_exp_elt_opcode (BINOP_LESS); }
 453         ;
 454
 455 exp     :       exp '>' exp
 456                         { write_exp_elt_opcode (BINOP_GTR); }
 457         ;
 458
 459 exp     :       exp LOGICAL_AND exp
 460                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 461         ;
 462
 463 exp     :       exp OROR exp
 464                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 465         ;
 466
 467 exp     :       exp ASSIGN exp
 468                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 469         ;
 470
 471
 472 /* Constants */
 473
 474 exp     :       M2_TRUE
 475                         { write_exp_elt_opcode (OP_BOOL);
 476                           write_exp_elt_longcst ((LONGEST) $1);
 477                           write_exp_elt_opcode (OP_BOOL); }
 478         ;
 479
 480 exp     :       M2_FALSE
 481                         { write_exp_elt_opcode (OP_BOOL);
 482                           write_exp_elt_longcst ((LONGEST) $1);
 483                           write_exp_elt_opcode (OP_BOOL); }
 484         ;
 485
 486 exp     :       INT
 487                         { write_exp_elt_opcode (OP_LONG);
 488                           write_exp_elt_type (builtin_type_m2_int);
 489                           write_exp_elt_longcst ((LONGEST) $1);
 490                           write_exp_elt_opcode (OP_LONG); }
 491         ;
 492
 493 exp     :       UINT
 494                         {
 495                           write_exp_elt_opcode (OP_LONG);
 496                           write_exp_elt_type (builtin_type_m2_card);
 497                           write_exp_elt_longcst ((LONGEST) $1);
 498                           write_exp_elt_opcode (OP_LONG);
 499                         }
 500         ;
 501
 502 exp     :       CHAR
 503                         { write_exp_elt_opcode (OP_LONG);
 504                           write_exp_elt_type (builtin_type_m2_char);
 505                           write_exp_elt_longcst ((LONGEST) $1);
 506                           write_exp_elt_opcode (OP_LONG); }
 507         ;
 508
 509
 510 exp     :       FLOAT
 511                         { write_exp_elt_opcode (OP_DOUBLE);
 512                           write_exp_elt_type (builtin_type_m2_real);
 513                           write_exp_elt_dblcst ($1);
 514                           write_exp_elt_opcode (OP_DOUBLE); }
 515         ;
 516
 517 exp     :       variable
 518         ;
 519
 520 exp     :       SIZE '(' type ')'       %prec UNARY
 521                         { write_exp_elt_opcode (OP_LONG);
 522                           write_exp_elt_type (builtin_type_int);
 523                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 524                           write_exp_elt_opcode (OP_LONG); }
 525         ;
 526
 527 exp     :       STRING
 528                         { write_exp_elt_opcode (OP_M2_STRING);
 529                           write_exp_string ($1);
 530                           write_exp_elt_opcode (OP_M2_STRING); }
 531         ;
 532
 533 /* This will be used for extensions later.  Like adding modules. */
 534 block   :       fblock
 535                         { $$ = SYMBOL_BLOCK_VALUE($1); }
 536         ;
 537
 538 fblock  :       BLOCKNAME
 539                         { struct symbol *sym
 540                             = lookup_symbol (copy_name ($1), expression_context_block,
 541                                              VAR_NAMESPACE, 0, NULL);
 542                           $$ = sym;}
 543         ;
 544
 545
 546 /* GDB scope operator */
 547 fblock  :       block COLONCOLON BLOCKNAME
 548                         { struct symbol *tem
 549                             = lookup_symbol (copy_name ($3), $1,
 550                                              VAR_NAMESPACE, 0, NULL);
 551                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
 552                             error ("No function \"%s\" in specified context.",
 553                                    copy_name ($3));
 554                           $$ = tem;
 555                         }
 556         ;
 557
 558 /* Useful for assigning to PROCEDURE variables */
 559 variable:       fblock
 560                         { write_exp_elt_opcode(OP_VAR_VALUE);
 561                           write_exp_elt_block (NULL);
 562                           write_exp_elt_sym ($1);
 563                           write_exp_elt_opcode (OP_VAR_VALUE); }
 564         ;
 565
 566 /* GDB internal ($foo) variable */
 567 variable:       INTERNAL_VAR
 568         ;
 569
 570 /* GDB scope operator */
 571 variable:       block COLONCOLON NAME
 572                         { struct symbol *sym;
 573                           sym = lookup_symbol (copy_name ($3), $1,
 574                                                VAR_NAMESPACE, 0, NULL);
 575                           if (sym == 0)
 576                             error ("No symbol \"%s\" in specified context.",
 577                                    copy_name ($3));
 578
 579                           write_exp_elt_opcode (OP_VAR_VALUE);
 580                           /* block_found is set by lookup_symbol.  */
 581                           write_exp_elt_block (block_found);
 582                           write_exp_elt_sym (sym);
 583                           write_exp_elt_opcode (OP_VAR_VALUE); }
 584         ;
 585
 586 /* Base case for variables. */
 587 variable:       NAME
 588                         { struct symbol *sym;
 589                           int is_a_field_of_this;
 590
 591                           sym = lookup_symbol (copy_name ($1),
 592                                                expression_context_block,
 593                                                VAR_NAMESPACE,
 594                                                &is_a_field_of_this,
 595                                                NULL);
 596                           if (sym)
 597                             {
 598                               if (symbol_read_needs_frame (sym))
 599                                 {
 600                                   if (innermost_block == 0 ||
 601                                       contained_in (block_found,
 602                                                     innermost_block))
 603                                     innermost_block = block_found;
 604                                 }
 605
 606                               write_exp_elt_opcode (OP_VAR_VALUE);
 607                               /* We want to use the selected frame, not
 608                                  another more inner frame which happens to
 609                                  be in the same block.  */
 610                               write_exp_elt_block (NULL);
 611                               write_exp_elt_sym (sym);
 612                               write_exp_elt_opcode (OP_VAR_VALUE);
 613                             }
 614                           else
 615                             {
 616                               struct minimal_symbol *msymbol;
 617                               register char *arg = copy_name ($1);
 618
 619                               msymbol =
 620                                 lookup_minimal_symbol (arg, NULL, NULL);
 621                               if (msymbol != NULL)
 622                                 {
 623                                   write_exp_msymbol
 624                                     (msymbol,
 625                                      lookup_function_type (builtin_type_int),
 626                                      builtin_type_int);
 627                                 }
 628                               else if (!have_full_symbols () && !have_partial_symbols ())
 629                                 error ("No symbol table is loaded.  Use the \"symbol-file\" command.");
 630                               else
 631                                 error ("No symbol \"%s\" in current context.",
 632                                        copy_name ($1));
 633                             }
 634                         }
 635         ;
 636
 637 type
 638         :       TYPENAME
 639                         { $$ = lookup_typename (copy_name ($1),
 640                                                 expression_context_block, 0); }
 641
 642         ;
 643
 644 %%
 645
 646 #if 0  /* FIXME! */
 647 int
 648 overflow(a,b)
 649    long a,b;
 650 {
 651    return (MAX_OF_TYPE(builtin_type_m2_int) - b) < a;
 652 }
 653
 654 int
 655 uoverflow(a,b)
 656    unsigned long a,b;
 657 {
 658    return (MAX_OF_TYPE(builtin_type_m2_card) - b) < a;
 659 }
 660 #endif /* FIXME */
 661
 662 /* Take care of parsing a number (anything that starts with a digit).
 663    Set yylval and return the token type; update lexptr.
 664    LEN is the number of characters in it.  */
 665
 666 /*** Needs some error checking for the float case ***/
 667
 668 static int
 669 parse_number (olen)
 670      int olen;
 671 {
 672   register char *p = lexptr;
 673   register LONGEST n = 0;
 674   register LONGEST prevn = 0;
 675   register int c,i,ischar=0;
 676   register int base = input_radix;
 677   register int len = olen;
 678   int unsigned_p = number_sign == 1 ? 1 : 0;
 679
 680   if(p[len-1] == 'H')
 681   {
 682      base = 16;
 683      len--;
 684   }
 685   else if(p[len-1] == 'C' || p[len-1] == 'B')
 686   {
 687      base = 8;
 688      ischar = p[len-1] == 'C';
 689      len--;
 690   }
 691
 692   /* Scan the number */
 693   for (c = 0; c < len; c++)
 694   {
 695     if (p[c] == '.' && base == 10)
 696       {
 697         /* It's a float since it contains a point.  */
 698         yylval.dval = atof (p);
 699         lexptr += len;
 700         return FLOAT;
 701       }
 702     if (p[c] == '.' && base != 10)
 703        error("Floating point numbers must be base 10.");
 704     if (base == 10 && (p[c] < '0' || p[c] > '9'))
 705        error("Invalid digit \'%c\' in number.",p[c]);
 706  }
 707
 708   while (len-- > 0)
 709     {
 710       c = *p++;
 711       n *= base;
 712       if( base == 8 && (c == '8' || c == '9'))
 713          error("Invalid digit \'%c\' in octal number.",c);
 714       if (c >= '0' && c <= '9')
 715         i = c - '0';
 716       else
 717         {
 718           if (base == 16 && c >= 'A' && c <= 'F')
 719             i = c - 'A' + 10;
 720           else
 721              return ERROR;
 722         }
 723       n+=i;
 724       if(i >= base)
 725          return ERROR;
 726       if(!unsigned_p && number_sign == 1 && (prevn >= n))
 727          unsigned_p=1;          /* Try something unsigned */
 728       /* Don't do the range check if n==i and i==0, since that special
 729          case will give an overflow error. */
 730       if(RANGE_CHECK && n!=i && i)
 731       {
 732          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
 733             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
 734             range_error("Overflow on numeric constant.");
 735       }
 736          prevn=n;
 737     }
 738
 739   lexptr = p;
 740   if(*p == 'B' || *p == 'C' || *p == 'H')
 741      lexptr++;                  /* Advance past B,C or H */
 742
 743   if (ischar)
 744   {
 745      yylval.ulval = n;
 746      return CHAR;
 747   }
 748   else if ( unsigned_p && number_sign == 1)
 749   {
 750      yylval.ulval = n;
 751      return UINT;
 752   }
 753   else if((unsigned_p && (n<0))) {
 754      range_error("Overflow on numeric constant -- number too large.");
 755      /* But, this can return if range_check == range_warn.  */
 756   }
 757   yylval.lval = n;
 758   return INT;
 759 }
 760
 761
 762 /* Some tokens */
 763
 764 static struct
 765 {
 766    char name[2];
 767    int token;
 768 } tokentab2[] =
 769 {
 770     { {'<', '>'},    NOTEQUAL   },
 771     { {':', '='},    ASSIGN     },
 772     { {'<', '='},    LEQ        },
 773     { {'>', '='},    GEQ        },
 774     { {':', ':'},    COLONCOLON },
 775
 776 };
 777
 778 /* Some specific keywords */
 779
 780 struct keyword {
 781    char keyw[10];
 782    int token;
 783 };
 784
 785 static struct keyword keytab[] =
 786 {
 787     {"OR" ,   OROR       },
 788     {"IN",    IN         },/* Note space after IN */
 789     {"AND",   LOGICAL_AND},
 790     {"ABS",   ABS        },
 791     {"CHR",   CHR        },
 792     {"DEC",   DEC        },
 793     {"NOT",   NOT        },
 794     {"DIV",   DIV        },
 795     {"INC",   INC        },
 796     {"MAX",   MAX_FUNC   },
 797     {"MIN",   MIN_FUNC   },
 798     {"MOD",   MOD        },
 799     {"ODD",   ODD        },
 800     {"CAP",   CAP        },
 801     {"ORD",   ORD        },
 802     {"VAL",   VAL        },
 803     {"EXCL",  EXCL       },
 804     {"HIGH",  HIGH       },
 805     {"INCL",  INCL       },
 806     {"SIZE",  SIZE       },
 807     {"FLOAT", FLOAT_FUNC },
 808     {"TRUNC", TRUNC      },
 809 };
 810
 811
 812 /* Read one token, getting characters through lexptr.  */
 813
 814 /* This is where we will check to make sure that the language and the operators used are
 815    compatible  */
 816
 817 static int
 818 yylex ()
 819 {
 820   register int c;
 821   register int namelen;
 822   register int i;
 823   register char *tokstart;
 824   register char quote;
 825
 826  retry:
 827
 828   tokstart = lexptr;
 829
 830
 831   /* See if it is a special token of length 2 */
 832   for( i = 0 ; i < (int) (sizeof tokentab2 / sizeof tokentab2[0]) ; i++)
 833      if(STREQN(tokentab2[i].name, tokstart, 2))
 834      {
 835         lexptr += 2;
 836         return tokentab2[i].token;
 837      }
 838
 839   switch (c = *tokstart)
 840     {
 841     case 0:
 842       return 0;
 843
 844     case ' ':
 845     case '\t':
 846     case '\n':
 847       lexptr++;
 848       goto retry;
 849
 850     case '(':
 851       paren_depth++;
 852       lexptr++;
 853       return c;
 854
 855     case ')':
 856       if (paren_depth == 0)
 857         return 0;
 858       paren_depth--;
 859       lexptr++;
 860       return c;
 861
 862     case ',':
 863       if (comma_terminates && paren_depth == 0)
 864         return 0;
 865       lexptr++;
 866       return c;
 867
 868     case '.':
 869       /* Might be a floating point number.  */
 870       if (lexptr[1] >= '0' && lexptr[1] <= '9')
 871         break;                  /* Falls into number code.  */
 872       else
 873       {
 874          lexptr++;
 875          return DOT;
 876       }
 877
 878 /* These are character tokens that appear as-is in the YACC grammar */
 879     case '+':
 880     case '-':
 881     case '*':
 882     case '/':
 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       lexptr++;
 896       return c;
 897
 898     case '\'' :
 899     case '"':
 900       quote = c;
 901       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
 902         if (c == '\\')
 903           {
 904             c = tokstart[++namelen];
 905             if (c >= '0' && c <= '9')
 906               {
 907                 c = tokstart[++namelen];
 908                 if (c >= '0' && c <= '9')
 909                   c = tokstart[++namelen];
 910               }
 911           }
 912       if(c != quote)
 913          error("Unterminated string or character constant.");
 914       yylval.sval.ptr = tokstart + 1;
 915       yylval.sval.length = namelen - 1;
 916       lexptr += namelen + 1;
 917
 918       if(namelen == 2)          /* Single character */
 919       {
 920            yylval.ulval = tokstart[1];
 921            return CHAR;
 922       }
 923       else
 924          return STRING;
 925     }
 926
 927   /* Is it a number?  */
 928   /* Note:  We have already dealt with the case of the token '.'.
 929      See case '.' above.  */
 930   if ((c >= '0' && c <= '9'))
 931     {
 932       /* It's a number.  */
 933       int got_dot = 0, got_e = 0;
 934       register char *p = tokstart;
 935       int toktype;
 936
 937       for (++p ;; ++p)
 938         {
 939           if (!got_e && (*p == 'e' || *p == 'E'))
 940             got_dot = got_e = 1;
 941           else if (!got_dot && *p == '.')
 942             got_dot = 1;
 943           else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
 944                    && (*p == '-' || *p == '+'))
 945             /* This is the sign of the exponent, not the end of the
 946                number.  */
 947             continue;
 948           else if ((*p < '0' || *p > '9') &&
 949                    (*p < 'A' || *p > 'F') &&
 950                    (*p != 'H'))  /* Modula-2 hexadecimal number */
 951             break;
 952         }
 953         toktype = parse_number (p - tokstart);
 954         if (toktype == ERROR)
 955           {
 956             char *err_copy = (char *) alloca (p - tokstart + 1);
 957
 958             memcpy (err_copy, tokstart, p - tokstart);
 959             err_copy[p - tokstart] = 0;
 960             error ("Invalid number \"%s\".", err_copy);
 961           }
 962         lexptr = p;
 963         return toktype;
 964     }
 965
 966   if (!(c == '_' || c == '$'
 967         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
 968     /* We must have come across a bad character (e.g. ';').  */
 969     error ("Invalid character '%c' in expression.", c);
 970
 971   /* It's a name.  See how long it is.  */
 972   namelen = 0;
 973   for (c = tokstart[namelen];
 974        (c == '_' || c == '$' || (c >= '0' && c <= '9')
 975         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
 976        c = tokstart[++namelen])
 977     ;
 978
 979   /* The token "if" terminates the expression and is NOT
 980      removed from the input stream.  */
 981   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
 982     {
 983       return 0;
 984     }
 985
 986   lexptr += namelen;
 987
 988   /*  Lookup special keywords */
 989   for(i = 0 ; i < (int) (sizeof(keytab) / sizeof(keytab[0])) ; i++)
 990      if(namelen == strlen(keytab[i].keyw) && STREQN(tokstart,keytab[i].keyw,namelen))
 991            return keytab[i].token;
 992
 993   yylval.sval.ptr = tokstart;
 994   yylval.sval.length = namelen;
 995
 996   if (*tokstart == '$')
 997     {
 998       write_dollar_variable (yylval.sval);
 999       return INTERNAL_VAR;
1000     }
1001
1002   /* Use token-type BLOCKNAME for symbols that happen to be defined as
1003      functions.  If this is not so, then ...
1004      Use token-type TYPENAME for symbols that happen to be defined
1005      currently as names of types; NAME for other symbols.
1006      The caller is not constrained to care about the distinction.  */
1007  {
1008
1009
1010     char *tmp = copy_name (yylval.sval);
1011     struct symbol *sym;
1012
1013     if (lookup_partial_symtab (tmp))
1014       return BLOCKNAME;
1015     sym = lookup_symbol (tmp, expression_context_block,
1016                          VAR_NAMESPACE, 0, NULL);
1017     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1018       return BLOCKNAME;
1019     if (lookup_typename (copy_name (yylval.sval), expression_context_block, 1))
1020       return TYPENAME;
1021
1022     if(sym)
1023     {
1024        switch(sym->aclass)
1025        {
1026        case LOC_STATIC:
1027        case LOC_REGISTER:
1028        case LOC_ARG:
1029        case LOC_REF_ARG:
1030        case LOC_REGPARM:
1031        case LOC_REGPARM_ADDR:
1032        case LOC_LOCAL:
1033        case LOC_LOCAL_ARG:
1034        case LOC_BASEREG:
1035        case LOC_BASEREG_ARG:
1036        case LOC_CONST:
1037        case LOC_CONST_BYTES:
1038        case LOC_OPTIMIZED_OUT:
1039           return NAME;
1040
1041        case LOC_TYPEDEF:
1042           return TYPENAME;
1043
1044        case LOC_BLOCK:
1045           return BLOCKNAME;
1046
1047        case LOC_UNDEF:
1048           error("internal:  Undefined class in m2lex()");
1049
1050        case LOC_LABEL:
1051        case LOC_UNRESOLVED:
1052           error("internal:  Unforseen case in m2lex()");
1053        }
1054     }
1055     else
1056     {
1057        /* Built-in BOOLEAN type.  This is sort of a hack. */
1058        if(STREQN(tokstart,"TRUE",4))
1059        {
1060           yylval.ulval = 1;
1061           return M2_TRUE;
1062        }
1063        else if(STREQN(tokstart,"FALSE",5))
1064        {
1065           yylval.ulval = 0;
1066           return M2_FALSE;
1067        }
1068     }
1069
1070     /* Must be another type of name... */
1071     return NAME;
1072  }
1073 }
1074
1075 #if 0           /* Unused */
1076 static char *
1077 make_qualname(mod,ident)
1078    char *mod, *ident;
1079 {
1080    char *new = malloc(strlen(mod)+strlen(ident)+2);
1081
1082    strcpy(new,mod);
1083    strcat(new,".");
1084    strcat(new,ident);
1085    return new;
1086 }
1087 #endif  /* 0 */
1088
1089 void
1090 yyerror (msg)
1091      char *msg;
1092 {
1093   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1094 }