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