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