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