gdb/m2-exp.y

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