gdb/m2-exp.y

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