gdb/m2-exp.y

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