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